diff --git a/Project/Delphi2005/Apophysis7X.bdsproj b/Project/Delphi2005/Apophysis7X.bdsproj deleted file mode 100644 index 2a7c351..0000000 --- a/Project/Delphi2005/Apophysis7X.bdsproj +++ /dev/null @@ -1,173 +0,0 @@ - - - - - - - - - - - - Apophysis7X.dpr - - - 7.0 - - - 8 - 0 - 1 - 1 - 0 - 0 - 1 - 1 - 0 - 0 - 0 - 1 - 0 - 1 - 1 - 1 - 0 - 0 - 0 - 0 - 0 - 1 - 0 - 1 - 2 - 1 - False - True - WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; - - False - - False - True - False - True - True - False - False - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - False - False - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - True - False - False - False - True - True - True - - - 0 - 0 - 1 - False - False - False - 16384 - 1048576 - 4194304 - - - - ..\..\out - ..\..\out\dcu - - - $(BDS)\lib\Debug;$(BDS)\Lib\Debug\Indy10;$(DELPHI)\Lib\Debug;..\..\..\Apolibstuff\libxml;..\..\..\Apolibstuff\imglib;..\..\..\Apolibstuff\Scripter\Imports\Delphi7;..\..\..\Apolibstuff\Scripter;..\..\..\ApoLibStuff\pngimage - vcl;rtl;dbrtl;adortl;vcldb;vclx;bdertl;vcldbx;dsnap;cds;bdecds;teeui;teedb;tee;dss;visualclx;visualdbclx;dsnapcrba;dsnapcon;VclSmp;vclie;xmlrtl;inet;inetdbbde;inetdbxpress;inetdb;nmfast;webdsnap;websnap;soaprtl;dbexpress;dbxcds;dclOffice2k;FlatStyle_D6;S303_R60;RzLPDB60;RzLPND60;vclshlctrls;B302vr60;VirtualTreesD6;o403_r60;ibxpress;CSP20I60;Rz30Ctls60;Rz30DBCtls60;indy;Indy60 - - ..\..\..\ApoLibStuff\pngimage\ - False - - - - - - False - - - - - - False - - - - $00000000 - - - - False - False - 2 - 0 - 9 - 1325 - False - False - False - False - False - 1033 - 1252 - - - - Apophysis 7X - 2.0.9.1325 - - Copyright © 2005-2010 Apophysis Developers Team - - Apophysis.exe - - 7X.13 - - - - diff --git a/Project/Delphi2005/Apophysis7X.bdsproj.local b/Project/Delphi2005/Apophysis7X.bdsproj.local deleted file mode 100644 index 32c6268..0000000 --- a/Project/Delphi2005/Apophysis7X.bdsproj.local +++ /dev/null @@ -1,9 +0,0 @@ - - - - 2010-07-15 13:08:39.405.pas,E:\Georg Kiehne\Projects\apophysis-7x\trunk\Project\Delphi2005\Unit1.pas=E:\Georg Kiehne\Projects\apophysis-7x\trunk\Source\SplashForm.pas - 2010-07-15 13:08:39.405.dfm,E:\Georg Kiehne\Projects\apophysis-7x\trunk\Project\Delphi2005\Unit1.dfm=E:\Georg Kiehne\Projects\apophysis-7x\trunk\Source\SplashForm.dfm - 2010-07-16 19:29:47.671.pas,E:\Georg Kiehne\Projects\apophysis-7x\trunk\Project\Delphi2005\Unit1.pas=E:\Georg Kiehne\Projects\apophysis-7x\trunk\Source\ThumbnailThread.pas - 2010-07-16 20:06:53.037.pas,E:\Georg Kiehne\Projects\apophysis-7x\trunk\Source\ThumbnailThread.pas= - - diff --git a/Project/Delphi2005/Apophysis7X.cfg b/Project/Delphi2005/Apophysis7X.cfg deleted file mode 100644 index 7235dfa..0000000 --- a/Project/Delphi2005/Apophysis7X.cfg +++ /dev/null @@ -1,44 +0,0 @@ --$A8 --$B- --$C+ --$D+ --$E- --$F- --$G+ --$H+ --$I- --$J- --$K- --$L+ --$M- --$N+ --$O+ --$P+ --$Q- --$R- --$S- --$T- --$U- --$V+ --$W- --$X+ --$Y+ --$Z1 --cg --AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; --H- --W- --M --$M16384,1048576 --K$00400000 --E"..\..\out" --N"..\..\out\dcu" --LE"E:\Georg Kiehne\Documents\Borland Studio Projects\Bpl" --LN"E:\Georg Kiehne\Documents\Borland Studio Projects\Bpl" --U"d:\suites\borland\delphi2005\lib\Debug;d:\suites\borland\delphi2005\Lib\Debug\Indy10;d:\suites\borland\delphi2005\Lib\Debug;..\..\..\Apolibstuff\libxml;..\..\..\Apolibstuff\imglib;..\..\..\Apolibstuff\Scripter\Imports\Delphi7;..\..\..\Apolibstuff\Scripter;..\..\..\ApoLibStuff\pngimage" --O"d:\suites\borland\delphi2005\lib\Debug;d:\suites\borland\delphi2005\Lib\Debug\Indy10;d:\suites\borland\delphi2005\Lib\Debug;..\..\..\Apolibstuff\libxml;..\..\..\Apolibstuff\imglib;..\..\..\Apolibstuff\Scripter\Imports\Delphi7;..\..\..\Apolibstuff\Scripter;..\..\..\ApoLibStuff\pngimage" --I"d:\suites\borland\delphi2005\lib\Debug;d:\suites\borland\delphi2005\Lib\Debug\Indy10;d:\suites\borland\delphi2005\Lib\Debug;..\..\..\Apolibstuff\libxml;..\..\..\Apolibstuff\imglib;..\..\..\Apolibstuff\Scripter\Imports\Delphi7;..\..\..\Apolibstuff\Scripter;..\..\..\ApoLibStuff\pngimage" --R"d:\suites\borland\delphi2005\lib\Debug;d:\suites\borland\delphi2005\Lib\Debug\Indy10;d:\suites\borland\delphi2005\Lib\Debug;..\..\..\Apolibstuff\libxml;..\..\..\Apolibstuff\imglib;..\..\..\Apolibstuff\Scripter\Imports\Delphi7;..\..\..\Apolibstuff\Scripter;..\..\..\ApoLibStuff\pngimage" --w-UNSAFE_TYPE --w-UNSAFE_CODE --w-UNSAFE_CAST diff --git a/Project/Delphi2005/Apophysis7X.dpr b/Project/Delphi2005/Apophysis7X.dpr deleted file mode 100644 index 72feba9..0000000 --- a/Project/Delphi2005/Apophysis7X.dpr +++ /dev/null @@ -1,145 +0,0 @@ -{ - Apophysis Copyright (C) 2001-2004 Mark Townsend - Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov - Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -} -program Apophysis7X; - -{%ToDo 'Apophysis7X.todo'} -{$R 'res\Apophysis7X.res'} - -uses - FastMM4 in '..\..\Source\System\FastMM4.pas', - FastMM4Messages in '..\..\Source\System\FastMM4Messages.pas', - Forms, - Dialogs, - SysUtils, - Binary in '..\..\Source\IO\Binary.pas', - Hibernation in '..\..\Source\IO\Hibernation.pas', - Base64 in '..\..\Source\IO\Base64.pas', - AsmRandom in '..\..\Source\System\AsmRandom.pas', - CommandLine in '..\..\Source\IO\CommandLine.pas', - BucketFillerThread in '..\..\Source\Renderer\BucketFillerThread.pas', - cmapdata in '..\..\Source\ColorMap\cmapdata.pas', - cmap in '..\..\Source\ColorMap\cmap.pas', - ControlPoint in '..\..\Source\Flame\ControlPoint.pas', - CustomDrawControl in '..\..\Source\System\CustomDrawControl.pas', - Global in '..\..\Source\Core\Global.pas', - GradientHlpr in '..\..\Source\ColorMap\GradientHlpr.pas', - ImageMaker in '..\..\Source\Renderer\ImageMaker.pas', - MissingPlugin in '..\..\Source\IO\MissingPlugin.pas', - NativeXmlObjectStorage in '..\..\Source\System\NativeXmlObjectStorage.pas', - NativeXml in '..\..\Source\System\NativeXml.pas', - NativeXmlAppend in '..\..\Source\System\NativeXmlAppend.pas', - RegexHelper in '..\..\Source\System\RegexHelper.pas', - Regstry in '..\..\Source\IO\Regstry.pas', - Render in '..\..\Source\Renderer\Render.pas', - Render32 in '..\..\Source\Renderer\Render32.pas', - Render32MT in '..\..\Source\Renderer\Render32MT.pas', - RenderThread in '..\..\Source\Renderer\RenderThread.pas', - RenderMT in '..\..\Source\Renderer\RenderMT.pas', - RenderST in '..\..\Source\Renderer\RenderST.pas', - RenderTypes in '..\..\Source\Renderer\RenderTypes.pas', - RndFlame in '..\..\Source\Flame\RndFlame.pas', - sdStringTable in '..\..\Source\System\sdStringTable.pas', - Translation in '..\..\Source\Core\Translation.pas', - varRadialBlur in '..\..\Source\Variations\varRadialBlur.pas', - varRings2 in '..\..\Source\Variations\varRings2.pas', - varFan2 in '..\..\Source\Variations\varFan2.pas', - varPDJ in '..\..\Source\Variations\varPDJ.pas', - varJuliaN in '..\..\Source\Variations\varJuliaN.pas', - varJuliaScope in '..\..\Source\Variations\varJuliaScope.pas', - varJulia3Djf in '..\..\Source\Variations\varJulia3Djf.pas', - varJulia3Dz in '..\..\Source\Variations\varJulia3Dz.pas', - varCurl in '..\..\Source\Variations\varCurl.pas', - varCurl3D in '..\..\Source\Variations\varCurl3D.pas', - varRectangles in '..\..\Source\Variations\varRectangles.pas', - varHemisphere in '..\..\Source\Variations\varHemisphere.pas', - varGenericPlugin in '..\..\Source\Variations\varGenericPlugin.pas', - BaseVariation in '..\..\Source\Core\BaseVariation.pas', - XFormMan in '..\..\Source\Core\XFormMan.pas', - XForm in '..\..\Source\Flame\XForm.pas', - Main in '..\..\Source\Forms\Main.pas' {MainForm}, - Tracer in '..\..\Source\Forms\Tracer.pas' {TraceForm}, - About in '..\..\Source\Forms\About.pas' {AboutForm}, - Adjust in '..\..\Source\Forms\Adjust.pas' {AdjustForm}, - Browser in '..\..\Source\Forms\Browser.pas' {GradientBrowser}, - Editor in '..\..\Source\Forms\Editor.pas' {EditForm}, - FormExport in '..\..\Source\Forms\FormExport.pas' {ExportDialog}, - FormExportC in '..\..\Source\Forms\FormExportC.pas' {ExportCDialog}, - FormFavorites in '..\..\Source\Forms\FormFavorites.pas' {FavoritesForm}, - formPostProcess in '..\..\Source\Forms\formPostProcess.pas' {frmPostProcess}, - FormRender in '..\..\Source\Forms\FormRender.pas' {RenderForm}, - Fullscreen in '..\..\Source\Forms\Fullscreen.pas' {FullscreenForm}, - ImageColoring in '..\..\Source\Forms\ImageColoring.pas' {frmImageColoring}, - LoadTracker in '..\..\Source\Forms\LoadTracker.pas' {LoadForm}, - Mutate in '..\..\Source\Forms\Mutate.pas' {MutateForm}, - Options in '..\..\Source\Forms\Options.pas' {OptionsForm}, - Preview in '..\..\Source\Forms\Preview.pas' {PreviewForm}, - Save in '..\..\Source\Forms\Save.pas' {SaveForm}, - SavePreset in '..\..\Source\Forms\SavePreset.pas' {SavePresetForm}, - ScriptForm in '..\..\Source\Forms\ScriptForm.pas' {ScriptEditor}, - ScriptRender in '..\..\Source\Forms\ScriptRender.pas' {ScriptRenderForm}, - SplashForm in '..\..\Source\Forms\SplashForm.pas' {SplashWindow}, - Template in '..\..\Source\Forms\Template.pas' {TemplateForm}, - MapmPlugin in '..\..\Managed\Mapm\Delphi\MapmPlugin.pas', - Mapm in '..\..\Managed\Mapm\Delphi\Mapm.pas', - MapmException in '..\..\Managed\Mapm\Delphi\MapmException.pas', - MapmMonitor in '..\..\Managed\Mapm\Delphi\MapmMonitor.pas'; - -begin - SplashWindow := TSplashWindow.Create(Application) ; - SplashWindow.Show; - Application.Initialize; - SplashWindow.Update; - - Application.Title := 'Apophysis 7x'; - Application.HelpFile := 'Apophysis7x.chm'; - //Application.CreateForm(TSplashWindow, SplashWindow); - Application.CreateForm(TMainForm, MainForm); - Application.CreateForm(TTraceForm, TraceForm); - Application.CreateForm(TAboutForm, AboutForm); - Application.CreateForm(TAdjustForm, AdjustForm); - Application.CreateForm(TGradientBrowser, GradientBrowser); - Application.CreateForm(TEditForm, EditForm); - Application.CreateForm(TExportDialog, ExportDialog); - Application.CreateForm(TExportCDialog, ExportCDialog); - Application.CreateForm(TFavoritesForm, FavoritesForm); - Application.CreateForm(TfrmPostProcess, frmPostProcess); - Application.CreateForm(TRenderForm, RenderForm); - Application.CreateForm(TFullscreenForm, FullscreenForm); - Application.CreateForm(TfrmImageColoring, frmImageColoring); - Application.CreateForm(TLoadForm, LoadForm); - Application.CreateForm(TMutateForm, MutateForm); - Application.CreateForm(TOptionsForm, OptionsForm); - Application.CreateForm(TPreviewForm, PreviewForm); - Application.CreateForm(TSaveForm, SaveForm); - Application.CreateForm(TSavePresetForm, SavePresetForm); - Application.CreateForm(TScriptEditor, ScriptEditor); - Application.CreateForm(TScriptRenderForm, ScriptRenderForm); - Application.CreateForm(TTemplateForm, TemplateForm); - Application.UpdateFormatSettings := False; - DebugSetLogFilePath(LPMAPMCHAR(ExtractFilePath(Application.ExeName) + 'mapm.log')); - DebugSetLoggingNoticesEnabled(B_TRUE); - PluginMonitor := TMapmMonitor.Create(ExtractFilePath(Application.ExeName) + 'Plugins'); - PluginMonitor.OnAddPlugin := MapmPluginAdd; - PluginMonitor.OnRemovePlugin := MapmPluginRemove; - DecimalSeparator := '.'; - Application.Run; -end. - - diff --git a/Project/Delphi2005/Apophysis7X.identcache b/Project/Delphi2005/Apophysis7X.identcache deleted file mode 100644 index 4d2033c..0000000 Binary files a/Project/Delphi2005/Apophysis7X.identcache and /dev/null differ diff --git a/Project/Delphi2005/Apophysis7X_Model.tgs b/Project/Delphi2005/Apophysis7X_Model.tgs deleted file mode 100644 index 8dc7357..0000000 --- a/Project/Delphi2005/Apophysis7X_Model.tgs +++ /dev/null @@ -1,6 +0,0 @@ - - - - Apophysis7X - - \ No newline at end of file diff --git a/Project/Delphi2005/Apophysis7X_Model.tgw b/Project/Delphi2005/Apophysis7X_Model.tgw deleted file mode 100644 index ce406ed..0000000 --- a/Project/Delphi2005/Apophysis7X_Model.tgw +++ /dev/null @@ -1,2 +0,0 @@ - - \ No newline at end of file diff --git a/Project/Delphi2005/PngImage.dcu b/Project/Delphi2005/PngImage.dcu deleted file mode 100644 index 0e360e1..0000000 Binary files a/Project/Delphi2005/PngImage.dcu and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_compile.obj b/Project/Delphi2005/lib/pcre_compile.obj deleted file mode 100644 index 84f8698..0000000 Binary files a/Project/Delphi2005/lib/pcre_compile.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_config.obj b/Project/Delphi2005/lib/pcre_config.obj deleted file mode 100644 index 4c8fd32..0000000 Binary files a/Project/Delphi2005/lib/pcre_config.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_default_tables.obj b/Project/Delphi2005/lib/pcre_default_tables.obj deleted file mode 100644 index 4b24e0c..0000000 Binary files a/Project/Delphi2005/lib/pcre_default_tables.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_dfa_exec.obj b/Project/Delphi2005/lib/pcre_dfa_exec.obj deleted file mode 100644 index d628a61..0000000 Binary files a/Project/Delphi2005/lib/pcre_dfa_exec.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_exec.obj b/Project/Delphi2005/lib/pcre_exec.obj deleted file mode 100644 index 94de74a..0000000 Binary files a/Project/Delphi2005/lib/pcre_exec.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_fullinfo.obj b/Project/Delphi2005/lib/pcre_fullinfo.obj deleted file mode 100644 index 6a7ff4f..0000000 Binary files a/Project/Delphi2005/lib/pcre_fullinfo.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_get.obj b/Project/Delphi2005/lib/pcre_get.obj deleted file mode 100644 index f42080d..0000000 Binary files a/Project/Delphi2005/lib/pcre_get.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_globals.obj b/Project/Delphi2005/lib/pcre_globals.obj deleted file mode 100644 index 062c13e..0000000 Binary files a/Project/Delphi2005/lib/pcre_globals.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_info.obj b/Project/Delphi2005/lib/pcre_info.obj deleted file mode 100644 index fb7438d..0000000 Binary files a/Project/Delphi2005/lib/pcre_info.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_maketables.obj b/Project/Delphi2005/lib/pcre_maketables.obj deleted file mode 100644 index 68658f0..0000000 Binary files a/Project/Delphi2005/lib/pcre_maketables.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_newline.obj b/Project/Delphi2005/lib/pcre_newline.obj deleted file mode 100644 index f710524..0000000 Binary files a/Project/Delphi2005/lib/pcre_newline.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_ord2utf8.obj b/Project/Delphi2005/lib/pcre_ord2utf8.obj deleted file mode 100644 index d1556f6..0000000 Binary files a/Project/Delphi2005/lib/pcre_ord2utf8.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_refcount.obj b/Project/Delphi2005/lib/pcre_refcount.obj deleted file mode 100644 index e9cdda3..0000000 Binary files a/Project/Delphi2005/lib/pcre_refcount.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_study.obj b/Project/Delphi2005/lib/pcre_study.obj deleted file mode 100644 index e1f28cf..0000000 Binary files a/Project/Delphi2005/lib/pcre_study.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_tables.obj b/Project/Delphi2005/lib/pcre_tables.obj deleted file mode 100644 index 94fa034..0000000 Binary files a/Project/Delphi2005/lib/pcre_tables.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_try_flipped.obj b/Project/Delphi2005/lib/pcre_try_flipped.obj deleted file mode 100644 index 5795787..0000000 Binary files a/Project/Delphi2005/lib/pcre_try_flipped.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_ucd.obj b/Project/Delphi2005/lib/pcre_ucd.obj deleted file mode 100644 index 77562db..0000000 Binary files a/Project/Delphi2005/lib/pcre_ucd.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_valid_utf8.obj b/Project/Delphi2005/lib/pcre_valid_utf8.obj deleted file mode 100644 index b6537d0..0000000 Binary files a/Project/Delphi2005/lib/pcre_valid_utf8.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_version.obj b/Project/Delphi2005/lib/pcre_version.obj deleted file mode 100644 index 0452f62..0000000 Binary files a/Project/Delphi2005/lib/pcre_version.obj and /dev/null differ diff --git a/Project/Delphi2005/lib/pcre_xclass.obj b/Project/Delphi2005/lib/pcre_xclass.obj deleted file mode 100644 index 627e282..0000000 Binary files a/Project/Delphi2005/lib/pcre_xclass.obj and /dev/null differ diff --git a/Project/Delphi2005/res/apophysis7x.res b/Project/Delphi2005/res/apophysis7x.res deleted file mode 100644 index 5a19a6e..0000000 Binary files a/Project/Delphi2005/res/apophysis7x.res and /dev/null differ diff --git a/Project/Delphi2005/zlibpas.dcu b/Project/Delphi2005/zlibpas.dcu deleted file mode 100644 index 6fdb552..0000000 Binary files a/Project/Delphi2005/zlibpas.dcu and /dev/null differ diff --git a/Project/Delphi2005/Apophysis7X.bdsgroup b/Source/Apophysis7X.bdsgroup similarity index 100% rename from Project/Delphi2005/Apophysis7X.bdsgroup rename to Source/Apophysis7X.bdsgroup diff --git a/Source/Apophysis7X.bdsproj b/Source/Apophysis7X.bdsproj new file mode 100644 index 0000000..094add3 --- /dev/null +++ b/Source/Apophysis7X.bdsproj @@ -0,0 +1,146 @@ + + + + + + + + + + + + Apophysis7X.dpr + + + 7.0 + + + 8 + 0 + 1 + 1 + 0 + 0 + 1 + 1 + 0 + 0 + 0 + 1 + 0 + 1 + 1 + 1 + 0 + 0 + 0 + 0 + 0 + 1 + 0 + 1 + 2 + 1 + False + True + WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; + + False + + False + True + False + True + True + False + False + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + False + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + True + False + False + False + True + True + True + + + 0 + 0 + 1 + False + False + False + 16384 + 1048576 + 4194304 + + + + ..\..\out + ..\..\out\dcu + + + $(BDS)\lib\Debug;$(BDS)\Lib\Debug\Indy10;$(DELPHI)\Lib\Debug + vcl;rtl;dbrtl;adortl;vcldb;vclx;bdertl;vcldbx;dsnap;cds;bdecds;teeui;teedb;tee;dss;visualclx;visualdbclx;dsnapcrba;dsnapcon;VclSmp;vclie;xmlrtl;inet;inetdbbde;inetdbxpress;inetdb;nmfast;webdsnap;websnap;soaprtl;dbexpress;dbxcds;dclOffice2k;FlatStyle_D6;S303_R60;RzLPDB60;RzLPND60;vclshlctrls;B302vr60;VirtualTreesD6;o403_r60;ibxpress;CSP20I60;Rz30Ctls60;Rz30DBCtls60;indy;Indy60;vclactnband + + + False + + + + + + False + + + + + + False + + + + $00000000 + + + + diff --git a/Source/Apophysis7X.dpr b/Source/Apophysis7X.dpr new file mode 100644 index 0000000..b3dc14c --- /dev/null +++ b/Source/Apophysis7X.dpr @@ -0,0 +1,215 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} +program Apophysis7X; + +{%ToDo 'Assets\Apophysis7X.todo'} +{$R 'Resources\Apophysis7X.res'} +{$SetPEFlags $20} + +uses + +{-- BASIC --} + FastMM4 in 'System\FastMM4.pas', + FastMM4Messages in 'System\FastMM4Messages.pas', + Forms, Dialogs, SysUtils, + Binary in 'IO\Binary.pas', + Base64 in 'IO\Base64.pas', + sdStringTable in 'System\sdStringTable.pas', + CustomDrawControl in 'System\CustomDrawControl.pas', + LibXmlComps in 'System\LibXmlComps.pas', + LibXmlParser in 'System\LibXmlParser.pas', + Windows7 in 'System\Windows7.pas', + RegexHelper in 'System\RegexHelper.pas', + CurvesControl in 'System\CurvesControl.pas', + + {$ifdef Apo7X64} + // if on x64, we don't use assembler + {$else} + AsmRandom in 'System\AsmRandom.pas', + {$endif} + +{-- CORE --} + Global in 'Core\Global.pas', + CommandLine in 'IO\CommandLine.pas', + MissingPlugin in 'IO\MissingPlugin.pas', + Regstry in 'IO\Regstry.pas', + Translation in 'Core\Translation.pas', + Chaotica in 'Core\Chaotica.pas', + ParameterIO in 'IO\ParameterIO.pas', + Bezier in 'Core\Bezier.pas', + +{-- FLAME --} + RndFlame in 'Flame\RndFlame.pas', + ControlPoint in 'Flame\ControlPoint.pas', + cmapdata in 'ColorMap\cmapdata.pas', + cmap in 'ColorMap\cmap.pas', + GradientHlpr in 'ColorMap\GradientHlpr.pas', + XFormMan in 'Core\XFormMan.pas', + XForm in 'Flame\XForm.pas', + BaseVariation in 'Core\BaseVariation.pas', + +{-- RENDERER --} + RenderingCommon in 'Rendering\RenderingCommon.pas', + RenderingInterface in 'Rendering\RenderingInterface.pas', + RenderingImplementation in 'Rendering\RenderingImplementation.pas', + BucketFillerThread in 'Rendering\BucketFillerThread.pas', + RenderThread in 'Rendering\RenderThread.pas', + ImageMaker in 'Rendering\ImageMaker.pas', + +{-- VARIATIONS --} + varHemisphere in 'Variations\varHemisphere.pas', + varLog in 'Variations\varLog.pas', + varPolar2 in 'Variations\varPolar2.pas', + varRings2 in 'Variations\varRings2.pas', + varFan2 in 'Variations\varFan2.pas', + varCross in 'Variations\varCross.pas', + varWedge in 'Variations\varWedge.pas', + varEpispiral in 'Variations\varEpispiral.pas', + varBwraps in 'Variations\varBwraps.pas', + varPDJ in 'Variations\varPDJ.pas', + varJuliaN in 'Variations\varJuliaN.pas', + varJuliaScope in 'Variations\varJuliaScope.pas', + varJulia3Djf in 'Variations\varJulia3Djf.pas', + varJulia3Dz in 'Variations\varJulia3Dz.pas', + varCurl in 'Variations\varCurl.pas', + varCurl3D in 'Variations\varCurl3D.pas', + varRadialBlur in 'Variations\varRadialBlur.pas', + varBlurCircle in 'Variations\varBlurCircle.pas', + varBlurZoom in 'Variations\varBlurZoom.pas', + varBlurPixelize in 'Variations\varBlurPixelize.pas', + varFalloff2 in 'Variations\varFalloff2.pas', + varRectangles in 'Variations\varRectangles.pas', + varSplits in 'Variations\varSplits.pas', + varSeparation in 'Variations\varSeparation.pas', + varBipolar in 'Variations\varBipolar.pas', + varLoonie in 'Variations\varLoonie.pas', + varEscher in 'Variations\varEscher.pas', + varScry in 'Variations\varScry.pas', + varNGon in 'Variations\varNGon.pas', + varFoci in 'Variations\varFoci.pas', + varLazysusan in 'Variations\varLazysusan.pas', + varMobius in 'Variations\varMobius.pas', + varCrop in 'Variations\varCrop.pas', + // circlecrop + varElliptic in 'Variations\varElliptic.pas', + varWaves2 in 'Variations\varWaves2.pas', + varAuger in 'Variations\varAuger.pas', + // glynnsim2 + // flux + // boarders2 + varPreSpherical in 'Variations\varPreSpherical.pas', + varPreSinusoidal in 'Variations\varPreSinusoidal.pas', + varPreDisc in 'Variations\varPreDisc.pas', + // pre_boarders2 + varPreBwraps in 'Variations\varPreBwraps.pas', + varPreCrop in 'Variations\varPreCrop.pas', + // pre_circlecrop + varPreFalloff2 in 'Variations\varPreFalloff2.pas', + // post_boarders2 + varPostBwraps in 'Variations\varPostBwraps.pas', + varPostCurl in 'Variations\varPostCurl.pas', + varPostCurl3D in 'Variations\varPostCurl3D.pas', + varPostCrop in 'Variations\varPostCrop.pas', + // post_circlecrop + varPostFalloff2 in 'Variations\varPostFalloff2.pas', + varGenericPlugin in 'Variations\varGenericPlugin.pas', + +{-- GUI --} + Main in 'Forms\Main.pas' {MainForm}, + Tracer in 'Forms\Tracer.pas' {TraceForm}, + About in 'Forms\About.pas' {AboutForm}, + Adjust in 'Forms\Adjust.pas' {AdjustForm}, + Browser in 'Forms\Browser.pas' {GradientBrowser}, + Editor in 'Forms\Editor.pas' {EditForm}, + FormExport in 'Forms\FormExport.pas' {ExportDialog}, + formPostProcess in 'Forms\formPostProcess.pas' {frmPostProcess}, + FormRender in 'Forms\FormRender.pas' {RenderForm}, + Fullscreen in 'Forms\Fullscreen.pas' {FullscreenForm}, + ImageColoring in 'Forms\ImageColoring.pas' {frmImageColoring}, + LoadTracker in 'Forms\LoadTracker.pas' {LoadForm}, + Mutate in 'Forms\Mutate.pas' {MutateForm}, + Options in 'Forms\Options.pas' {OptionsForm}, + Save in 'Forms\Save.pas' {SaveForm}, + SavePreset in 'Forms\SavePreset.pas' {SavePresetForm}, + SplashForm in 'Forms\SplashForm.pas' {SplashWindow}, + Template in 'Forms\Template.pas' {TemplateForm}, + Curves in 'Forms\Curves.pas' {CurvesForm} + + {$ifdef DisableScripting}; + // if scripting is disabled, don't import the scripting form units + {$else}, + Preview in 'Forms\Preview.pas' {PreviewForm}, + FormFavorites in 'Forms\FormFavorites.pas' {FavoritesForm}, + ScriptForm in 'Forms\ScriptForm.pas' {ScriptEditor}, + ScriptRender in 'Forms\ScriptRender.pas'; {ScriptRenderForm} + {$endif} + +begin + {$ifdef Apo7X64} + {$else} + InitializePlugins; + {$endif} + + SplashWindow := TSplashWindow.Create(Application); + SplashWindow.Show; + + Application.Initialize; + SplashWindow.Update; + + {$ifdef Apo7X64} + Application.Title := 'Apophysis 7x (32 bit)'; + {$else} + Application.Title := 'Apophysis 7x (64 bit)'; + {$endif} + Application.HelpFile := 'Apophysis7x.chm'; + Application.CreateForm(TMainForm, MainForm); + Application.CreateForm(TTraceForm, TraceForm); + Application.CreateForm(TAboutForm, AboutForm); + Application.CreateForm(TAdjustForm, AdjustForm); + Application.CreateForm(TGradientBrowser, GradientBrowser); + Application.CreateForm(TEditForm, EditForm); + Application.CreateForm(TExportDialog, ExportDialog); + Application.CreateForm(TfrmPostProcess, frmPostProcess); + Application.CreateForm(TRenderForm, RenderForm); + Application.CreateForm(TFullscreenForm, FullscreenForm); + Application.CreateForm(TfrmImageColoring, frmImageColoring); + Application.CreateForm(TLoadForm, LoadForm); + Application.CreateForm(TMutateForm, MutateForm); + Application.CreateForm(TOptionsForm, OptionsForm); + Application.CreateForm(TSaveForm, SaveForm); + Application.CreateForm(TSavePresetForm, SavePresetForm); + Application.CreateForm(TTemplateForm, TemplateForm); + Application.CreateForm(TCurvesForm, CurvesForm); + + {$ifdef DisableScripting} + // if scripting is disabled, don't create the scripting forms + {$else} + Application.CreateForm(TPreviewForm, PreviewForm); + Application.CreateForm(TFavoritesForm, FavoritesForm); + Application.CreateForm(TScriptEditor, ScriptEditor); + Application.CreateForm(TScriptRenderForm, ScriptRenderForm); + {$endif} + + Application.UpdateFormatSettings := False; + DecimalSeparator := '.'; + Application.Run; +end. + + diff --git a/Source/Assets/Apophysis7X.todo b/Source/Assets/Apophysis7X.todo new file mode 100644 index 0000000..e69de29 diff --git a/Plugin/apoplugin.h b/Source/Assets/Plugin/apoplugin.h similarity index 100% rename from Plugin/apoplugin.h rename to Source/Assets/Plugin/apoplugin.h diff --git a/Plugin/example-plugin.c b/Source/Assets/Plugin/example-plugin.c similarity index 100% rename from Plugin/example-plugin.c rename to Source/Assets/Plugin/example-plugin.c diff --git a/Source/ColorMap/cmap.pas b/Source/ColorMap/cmap.pas index 7ab69be..4ba7014 100644 --- a/Source/ColorMap/cmap.pas +++ b/Source/ColorMap/cmap.pas @@ -220,12 +220,12 @@ procedure GetTokens(s: string; var mlist: TStringList); test := s; while (Length(Test) > 0) do begin - while (Length(Test) > 0) and (test[1] in [#32]) do + while (Length(Test) > 0) and CharInSet(test[1],[#32]) do Delete(test, 1, 1); if (Length(Test) = 0) then exit; token := ''; - while (Length(Test) > 0) and (not (test[1] in [#32])) do + while (Length(Test) > 0) and (not CharInSet(test[1],[#32])) do begin token := token + test[1]; Delete(test, 1, 1); diff --git a/Source/Core/BaseVariation.pas b/Source/Core/BaseVariation.pas index ff39097..a15e0ba 100644 --- a/Source/Core/BaseVariation.pas +++ b/Source/Core/BaseVariation.pas @@ -88,10 +88,17 @@ TVariationClassLoader = class (TVariationLoader) VariationClass : TBaseVariationClass; end; +function fmod(x, y: double) : double; + implementation uses SysUtils; +function fmod(x, y: double) : double; +begin + Result := frac(x / y) * y; +end; + { TBaseVariation } /////////////////////////////////////////////////////////////////////////////// diff --git a/Source/Core/Bezier.pas b/Source/Core/Bezier.pas new file mode 100644 index 0000000..23bcae0 --- /dev/null +++ b/Source/Core/Bezier.pas @@ -0,0 +1,94 @@ +unit Bezier; + +interface + +uses Math; + + +type + BezierPoint = record + x, y: double; + end; + BezierRect = record + x0, y0, x1, y1: double; + end; + + BezierPoints = array [0..3] of BezierPoint; + BezierWeights = array [0..3] of double; + +procedure BezierCopy(src: BezierPoints; var tgt: BezierPoints); +procedure BezierSetRect(var points: BezierPoints; flip: boolean; rect: BezierRect); +procedure BezierUnsetRect(var points: BezierPoints; flip: boolean; rect: BezierRect); + +procedure BezierSolve(t: double; src: BezierPoints; w: BezierWeights; var solution: BezierPoint); +function BezierFunc(t: double; src: BezierPoints; w: BezierWeights): double; + +implementation + procedure BezierCopy(src: BezierPoints; var tgt: BezierPoints); + var + i, n: integer; + begin + n := Length(src); + for i := 0 to n - 1 do + tgt[i] := src[i]; + end; + procedure BezierSetRect(var points: BezierPoints; flip: boolean; rect: BezierRect); + var + i, n: integer; + f: double; + begin + n := Length(points); + for i := 0 to n - 1 do + begin + if (flip) then f := 1 - points[i].y + else f := points[i].y; + + points[i].x := points[i].x * (rect.x1 - rect.x0) + rect.x0; + points[i].y := f * (rect.y1 - rect.y0) + rect.y0; + end; + end; + procedure BezierUnsetRect(var points: BezierPoints; flip: boolean; rect: BezierRect); + var + i, n: integer; + f: double; + begin + if ((rect.x1 - rect.x0) = 0) or ((rect.y1 - rect.y0) = 0) then Exit; + + n := Length(points); + for i := 0 to n - 1 do + begin + points[i].x := (points[i].x - rect.x0) / (rect.x1 - rect.x0); + points[i].y := (points[i].y - rect.y0) / (rect.y1 - rect.y0); + + if (flip) then points[i].y := 1 - points[i].y; + end; + end; + + procedure BezierSolve(t: double; src: BezierPoints; w: BezierWeights; var solution: BezierPoint); + var + s, s2, s3, t2, t3, nom_x, nom_y, denom: double; + begin + s := 1 - t; + s2 := s * s; s3 := s * s * s; + t2 := t * t; t3 := t * t * t; + + nom_x := w[0] * s3 * src[0].x + w[1] * s2 * 3 * t * src[1].x + + w[2] * s * 3 * t2 * src[2].x + w[3] * t3 * src[3].x; + nom_y := w[0] * s3 * src[0].y + w[1] * s2 * 3 * t * src[1].y + + w[2] * s * 3 * t2 * src[2].y + w[3] * t3 * src[3].y; + denom := w[0] * s3 + w[1] * s2 * 3 * t + w[2] * s * 3 * t2 + w[3] * t3; + + if (IsNaN(nom_x)) or (IsNaN(nom_y)) or (IsNaN(denom)) then Exit; + if denom = 0 then Exit; + + solution.x := nom_x / denom; + solution.y := nom_y / denom; + end; + function BezierFunc(t: double; src: BezierPoints; w: BezierWeights): double; + var + p: BezierPoint; + begin + BezierSolve(t, src, w, p); + Result := p.y; + end; +end. diff --git a/Source/Core/Chaotica.pas b/Source/Core/Chaotica.pas new file mode 100644 index 0000000..ca38a1b --- /dev/null +++ b/Source/Core/Chaotica.pas @@ -0,0 +1,268 @@ +unit Chaotica; + +interface + +uses Global, RegularExpressionsCore, RegexHelper, Classes, SysUtils, XFormMan, Windows, + ShellAPI, Forms, ControlPoint, Translation; + +function C_GetPathOf(filename: string; usex64: boolean): string; +function C_SupportsDllPlugins(usex64: boolean): boolean; +function C_IsDllPluginBlacklisted(filename: string; usex64: boolean): boolean; +function C_IsVariationNative(name: string; usex64: boolean): boolean; +function C_IsDllPluginInstalled(filename: string): boolean; + +procedure C_SyncDllPlugins; +procedure C_InstallVariation(name: string); +procedure C_ExecuteChaotica(flamexml: string; plugins: TStringList; usex64: boolean); + +implementation + +uses Main; + +function CheckX64: Boolean; +var + SEInfo: TShellExecuteInfo; + ExitCode: DWORD; + ExecuteFile, ParamString, StartInString: string; +begin + {$ifdef Apo7X64} + Result := true; + exit; + {$endif} + + ExecuteFile:=ExtractFilePath(Application.ExeName)+'chk64.exe'; + FillChar(SEInfo, SizeOf(SEInfo), 0); + SEInfo.cbSize := SizeOf(TShellExecuteInfo); + + with SEInfo do begin + fMask := SEE_MASK_NOCLOSEPROCESS; + Wnd := Application.Handle; + lpFile := PChar(ExecuteFile) ; + nShow := SW_SHOWNORMAL; + end; + + if ShellExecuteEx(@SEInfo) then + begin + repeat + Application.ProcessMessages; + GetExitCodeProcess(SEInfo.hProcess, ExitCode); + until (ExitCode <> STILL_ACTIVE) or Application.Terminated; + Result := (ExitCode = 0); + end else begin + Result := false; + end; +end; + +function C_GetPathOf(filename: string; usex64: boolean): string; +var + subf: string; +begin + if usex64 then subf := '64bit' + else subf := '32bit'; + Result := ChaoticaPath + '\' + subf + '\' + filename; +end; + +function C_SupportsDllPlugins(usex64: boolean): boolean; +const + re_root : string = '.*?'; + re_attrib : string = 'supports_dll_plugins="(.*?)"'; +var + xml_file : TStringList; + xml_text, attrib, value : string; +begin + if usex64 then begin + Result := false; + Exit; + end; + + xml_file := TStringList.Create; + xml_file.LoadFromFile(C_GetPathOf('variation_compatibility.xml', false)); + xml_text := xml_file.Text; + xml_file.Destroy; + + attrib := GetStringPart(xml_text, re_root, 1, 'supports_dll_plugins="false"'); + value := GetStringPart(attrib, re_attrib, 1, 'false'); + + Result := (value = 'true'); +end; + +function C_IsDllPluginBlacklisted(filename: string; usex64: boolean): boolean; +var + i: integer; + blacklist: TStringList; +begin + blacklist := TStringList.Create; + blacklist.LoadFromFile(C_GetPathOf('plugin_dll_blacklist.txt', usex64)); + + for i := 0 to blacklist.Count - 1 do begin + if LowerCase(filename) = LowerCase(blacklist.Strings[i]) then begin + Result := true; + blacklist.Destroy; + Exit; + end; + end; + + blacklist.Destroy; + Result := false; +end; + +function C_IsVariationNative(name: string; usex64: boolean): boolean; +const + re_root : string = '(.*?)'; + re_var : string = ''; +var + xml, var_name : string; + xml_file : TStringList; + find_var : TPerlRegEx; + found_var : boolean; +begin + + xml_file := TStringList.Create; + xml_file.LoadFromFile(C_GetPathOf('variation_compatibility.xml', false)); + xml := xml_file.Text; + xml_file.Destroy; + + find_var := TPerlRegEx.Create; + find_var.RegEx := Utf8String(re_var); + find_var.Options := [preSingleLine, preCaseless]; + find_var.Subject := Utf8String(GetStringPart(xml, re_root, 1, '')); + found_var := find_var.Match; + + while found_var do begin + var_name := String(find_var.Groups[1]); + found_var := find_var.MatchAgain; + + if LowerCase(name) = var_name then begin + find_var.Destroy; + Result := true; + Exit; + end; + end; + + find_var.Destroy; + Result := false; +end; + +function C_IsDllPluginInstalled(filename: string): boolean; +var + path : string; +begin + path := C_GetPathOf('plugins\' + filename, false); + Result := FileExists(path); +end; + +//////////////////////////////////////////////////////////////////// + +procedure C_InstallVariation(name: string); +var + filename: string; +begin + filename := GetFileNameOfVariation(name); + + if (filename = '') then Exit; + if C_IsDllPluginInstalled(filename) then Exit; + + CopyFile(PCHAR(filename), PCHAR(C_GetPathOf('plugins\' + + ExtractFileName(filename), false)), false); +end; + +procedure C_SyncDllPlugins; +var + src_dir: string; + tgt_dir: string; + + searchResult: TSearchRec; +begin + src_dir := PluginPath; + tgt_dir := C_GetPathOf('Plugins', false); + + if (not DirectoryExists(src_dir)) then Exit; + if (not DirectoryExists(tgt_dir)) then Exit; + + // First clear all plugins on Chaotica side + if FindFirst(tgt_dir + '\*.dll', faAnyFile, searchResult) = 0 then + begin + repeat + DeleteFile(PCHAR(tgt_dir + '\' + searchResult.Name)) ; + until (FindNext(searchResult) <> 0); + SysUtils.FindClose(searchResult); + end; + + // Then copy all plugins from Apophysis to Chaotica + if FindFirst(src_dir + '*.dll', faAnyFile, searchResult) = 0 then + begin + repeat + if not C_IsDllPluginBlacklisted(searchResult.Name, false) + then CopyFile( + PCHAR(src_dir + '\' + searchResult.Name), + PCHAR(tgt_dir + '\' + searchResult.Name), + false); + until (FindNext(searchResult) <> 0); + SysUtils.FindClose(searchResult); + end; +end; + +procedure C_ExecuteChaotica(flamexml: string; plugins: TStringList; usex64: boolean); +var + i: integer; + name, fname: string; + fails: TStringList; + txt: TStringList; + fin_usex64: boolean; +begin + fails := TStringList.Create; + + {$ifdef Apo7X64} + fin_usex64 := true; + {$else} + fin_usex64 := usex64 and CheckX64; + for i := 0 to plugins.Count - 1 do begin + name := GetFileNameOfVariation(plugins.Strings[i]); + if (name = '') then name := plugins.Strings[i]; + fin_usex64 := fin_usex64 and C_IsVariationNative(name, usex64); + end; + + for i := 0 to plugins.Count - 1 do begin + name := GetFileNameOfVariation(plugins.Strings[i]); + if (name = '') then name := plugins.Strings[i]; // assume built-in + + if not C_IsVariationNative(name, fin_usex64) then begin // not native -> try install + if C_SupportsDllPlugins(fin_usex64) then // dll unsupported -> fail + fails.Add(plugins.Strings[i]) + else if C_IsDllPluginBlacklisted(name, fin_usex64) then // dll supported and blacklisted -> fail + fails.Add(plugins.Strings[i]) + ;//else C_InstallVariation(plugins.Strings[i]); // dll supported and not blacklisted -> install + // ^^^ this is done on Apophysis startup now! + end; + end; + {$endif} + + name := C_GetPathOf('chaotica.exe', fin_usex64); + if (not FileExists(name)) then begin + messagebox(0, PCHAR(TextByKey('main-status-nochaotica')), + PCHAR('Apophysis 7X'), MB_ICONHAND); + Exit; + end; + + if (fails.Count > 0) then begin + messagebox(0, PCHAR(TextByKey('main-status-oldchaotica')), + PCHAR('Apophysis 7X'), MB_ICONHAND or MB_OK); + end; + + fname := GetEnvironmentVariable('TEMP') + '\chaotica_export.flame'; + txt := TStringList.Create; + + txt.Text := flamexml; + txt.SaveToFile(fname); + + txt.Destroy; + fails.Destroy; + + //if fin_usex64 then MessageBox(0, PCHAR('DBG:x64'), PCHAR(''), MB_OK) + //else MessageBox(0, PCHAR('DBG:x86'), PCHAR(''), MB_OK) ; + + ShellExecute(application.handle, PChar('open'), pchar(name), + PChar('"' + fname + '"'), PChar(ExtractFilePath(name)), SW_SHOWNORMAL); +end; + +end. diff --git a/Source/Core/Global.pas b/Source/Core/Global.pas index a0ffca4..c73dc6f 100644 --- a/Source/Core/Global.pas +++ b/Source/Core/Global.pas @@ -27,7 +27,7 @@ interface uses Windows, SysUtils, Classes, SyncObjs, Controls, Graphics, Math, - cmap, ControlPoint, Xform, CommDlg, Mapm, MapmMonitor, MapmException; + cmap, ControlPoint, Xform, CommDlg; type EFormatInvalid = class(Exception); @@ -58,12 +58,17 @@ function OpenSaveFileDialog(Parent: TWinControl; NoChangeDir, DoOpen: Boolean): Boolean; procedure LoadThumbnailPlaceholder(ThumbnailSize : integer); +function GetEnvVarValue(const VarName: string): string; const APP_NAME: string = 'Apophysis 7x'; - APP_VERSION: string = 'Version 16 [Build 1547]'; - APP_BUILD: string = ''; + APP_VERSION: string = 'Version 15C.9'; + {$ifdef Apo7X64} + APP_BUILD: string = ' - 64 bit'; + {$else} + APP_BUILD: string = ' - 32 bit'; + {$endif} MAX_TRANSFORMS: integer = 100; prefilter_white: integer = 1024; eps: double = 1E-10; @@ -78,11 +83,16 @@ procedure LoadThumbnailPlaceholder(ThumbnailSize : integer); crEditMove = 21; crEditRotate = 22; crEditScale = 23; + +const + SingleBuffer : boolean = + {$ifdef Apo7X64} + false + {$else} + true + {$endif}; var - - PluginMonitor: TMapmMonitor; - MainSeed: integer; MainTriangles: TTriangles; Transforms: integer; // Count of Tranforms @@ -103,6 +113,7 @@ procedure LoadThumbnailPlaceholder(ThumbnailSize : integer); EmbedThumbnails : boolean; LanguageFile : string; AvailableLanguages : TStringList; + PluginPath : string; { UPR Options } @@ -228,6 +239,7 @@ procedure LoadThumbnailPlaceholder(ThumbnailSize : integer); defLibrary: string; LimitVibrancy: Boolean; DefaultPalette: TColorMap; + ChaoticaPath, ChaoticaPath64: string; UseX64IfPossible: boolean; @@ -245,6 +257,25 @@ function Round6(x: double): double; implementation +function GetEnvVarValue(const VarName: string): string; +var + BufSize: Integer; // buffer size required for value +begin + // Get required buffer size (inc. terminal #0) + BufSize := GetEnvironmentVariable( + PChar(VarName), nil, 0); + if BufSize > 0 then + begin + // Read env var value into result string + SetLength(Result, BufSize - 1); + GetEnvironmentVariable(PChar(VarName), + PChar(Result), BufSize); + end + else + // No such environment variable + Result := ''; +end; + procedure LoadThumbnailPlaceholder(ThumbnailSize : integer); var placeholder: TBitmap; @@ -441,15 +472,6 @@ function ReplaceTabs(str: string): string; Result := str; end; -procedure SinCos(const Theta: double; var Sin, Cos: double); // to avoid using 'extended' type -asm - FLD Theta - FSINCOS - FSTP qword ptr [edx] // Cos - FSTP qword ptr [eax] // Sin - FWAIT -end; - (* { Palette and gradient functions } diff --git a/Source/Core/Translation.pas b/Source/Core/Translation.pas index bcc8ed0..1a5d57a 100644 --- a/Source/Core/Translation.pas +++ b/Source/Core/Translation.pas @@ -2,7 +2,7 @@ interface -uses Global, Classes, Forms, LibXmlParser, LibXmlComps, SysUtils, RegexHelper, {Unicode,} NativeXML; +uses Global, Classes, Forms, LibXmlParser, LibXmlComps, SysUtils, RegexHelper; procedure ListLanguages; procedure LanguageInfo(path: string; var name, localName: string); @@ -60,17 +60,13 @@ procedure LanguageInfo(path: string; var name, localName: string); exp1 = '\stitle="([^"]*)"'; exp2 = '\slocalized-title="([^"]*)"'; var - langfile : TextFile; - buffer, langxml : string; + langxml : string; + sl: TStringList; begin - AssignFile(langfile, path) ; - Reset(langfile) ; - while not EOF(langfile) do - begin - ReadLn(langfile, buffer) ; - langxml := langxml + #13#10 + buffer; - end; - CloseFile(langfile) ; + sl := TStringList.Create; + sl.LoadFromFile(path); + langxml := sl.Text; + sl.Destroy; name := GetStringPart(langxml, exp1, 1, ''); localname := GetStringPart(langxml, exp2, 1, ''); @@ -79,17 +75,13 @@ function LanguageAuthor(path: string): string; const exp = '\sauthor="([^"]*)"'; var - langfile : TextFile; - buffer, langxml : string; + langxml : string; + sl: TStringList; begin - AssignFile(langfile, path) ; - Reset(langfile) ; - while not EOF(langfile) do - begin - ReadLn(langfile, buffer) ; - langxml := langxml + #13#10 + buffer; - end; - CloseFile(langfile) ; + sl := TStringList.Create; + sl.LoadFromFile(path); + langxml := sl.Text; + sl.Destroy; Result := GetStringPart(langxml, exp, 1, ''); end; @@ -220,6 +212,13 @@ procedure LoadEnglish(); Add('adjustment-tab-size-title', 'Image size'); Add('adjustment-tab-size-preset', 'Empty preset'); Add('adjustment-tab-size-resizemain', 'Resize main window'); + Add('adjustment-tab-curves-title', 'Curves'); + Add('adjustment-tab-curves-reset', 'Reset'); + Add('adjustment-tab-curves-selected', 'Selected curve:'); + Add('adjustment-tab-curves-overall', 'Overall'); + Add('adjustment-tab-curves-red', 'Red'); + Add('adjustment-tab-curves-green', 'Green'); + Add('adjustment-tab-curves-blue', 'Blue'); Add('adjustment-popup-quality-instantpreview', 'Instant preview'); Add('adjustment-popup-gradient-randomize', 'Randomize'); Add('adjustment-popup-gradient-invert', 'Invert'); @@ -362,14 +361,12 @@ procedure LoadEnglish(); Add('render-tab-output-title', 'Output'); Add('render-resourceusage-title', 'Resource usage'); Add('render-resourceusage-infotext', 'The render process will use %u MB of %u MB available physical memory'); + Add('render-resourceusage-infotext2', 'Apophysis will try to use %u processor cores (%u available) - change this in the options'); Add('render-resourceusage-limit', 'Memory limit'); Add('render-resourceusage-nolimit', 'No limit'); Add('render-resourceusage-bufferdepth', 'Buffer depth'); Add('render-output-title', 'Output options'); Add('render-output-saveparams', 'Save parameters'); - Add('render-output-writeexif', 'Write EXIF-Header (JPEG only)'); - Add('render-output-author', 'Author (EXIF)'); - Add('render-output-includeparams', 'Include parameters in EXIF-Header'); Add('render-completion-title', 'Completion options'); Add('render-completion-postprocess', 'Post-process after rendering'); Add('render-completion-shutdown', 'Shut down after rendering'); @@ -385,8 +382,8 @@ procedure LoadEnglish(); Add('render-status-elapsed', 'Elapsed'); Add('render-status-remaining', 'Remaining'); Add('render-status-slicestatus', 'Slice %d of %d'); - Add('render-status-notenoughmemory1', 'You do not have enough memory for this render. Please use memory limiting.'); - Add('render-status-notenoughmemory2', 'You do not have enough memory for this render. Please use a lower Maximum memory setting.'); + Add('render-status-notenoughmemory1', 'You do not have enough memory for this render. Do you want to continue anyway?'); + Add('render-status-notenoughmemory2', 'You do not have enough memory for this render. Please use a lower Maximum memory setting. Do you want to ignore this problem and continue?'); Add('render-status-nofilename', 'Please enter a file name.'); Add('render-status-fileexists-message1', '"%s" already exists'); Add('render-status-fileexists-message2', 'Do you want to replace it?'); @@ -396,7 +393,7 @@ procedure LoadEnglish(); Add('render-status-invalidoversample', 'Invalid Oversample value'); Add('render-status-invalidwidth', 'Invalid image width'); Add('render-status-invalidheight', 'Invalid image height'); - Add('render-status-maxmemorytoosmall', 'Maximum memory value is too small'); + Add('render-status-maxmemorytoosmall', 'Maximum memory value is too small. Do you want to continue anyway?'); Add('render-status-shuttingdownrender', 'Shutting down previous render...'); Add('render-status-log-title', 'Rendering "%s"'); Add('render-status-log-size', 'Size: %dx%d'); @@ -452,6 +449,8 @@ procedure LoadEnglish(); Add('options-tab-general-guidecentercolor', 'Center '); Add('options-tab-general-guidethirdscolor', 'Thirds '); Add('options-tab-general-guidegoldenratiocolor', 'Golden ratio '); + Add('options-tab-general-singleprecision', 'Use single-precision buffers '); + Add('options-tab-general-pluginpath', 'Plugin folder '); Add('options-tab-editor-title', 'Editor '); Add('options-tab-editor-editorgraph', 'Graph '); Add('options-tab-editor-editordefaults', 'Defaults '); @@ -584,6 +583,7 @@ procedure LoadEnglish(); Add('main-menu-view-mutation', 'Mutation'); Add('main-menu-view-imagesize', 'Image size'); Add('main-menu-view-messages', 'Messages'); + Add('main-menu-view-curves', 'Curves'); Add('main-menu-flame-title', 'Flame'); Add('main-menu-flame-reset', 'Reset location'); Add('main-menu-flame-randomize', 'Randomize'); @@ -640,8 +640,8 @@ procedure LoadEnglish(); Add('main-status-morepluginsneeded', 'The flame "%s" requires the following additional %s:'); Add('main-status-noautosave', 'No autosave present.'); Add('main-status-chaoticacompatmissing', 'The variation compatibility data file can not be found at the configured location of Chaotica. The rendering result may look different from the preview. Do you want to proceed?'); - Add('main-status-nochatocia', 'The executable file of Chaotica could not be found. Please check your settings.'); - Add('main-status-oldchaotica', 'It seems you are using a version of Chaotica prior than 0.3. The rendering result may look different from the preview. Do you want to proceed?'); + Add('main-status-nochaotica', 'The executable file of Chaotica could not be found. Please check your settings.'); + Add('main-status-oldchaotica', 'The rendering result may look different from the preview. Do you want to proceed?'); Add('main-report-transformcount', 'Transform count: %d'); Add('main-report-finaltransform', 'Has final transform: %s'); Add('main-report-usedplugins', 'Used plugins:'); @@ -670,33 +670,13 @@ procedure AddNoDefault(key, value: string); entry.value := value; language[tokenCount - 1] := entry; end; -procedure AddNodes(node: TXMLNode; keyName: UTF8string); -var i: integer; newName: UTF8String; -begin - for i:=0 to node.NodeCount - 1 do begin - if (node.Name <> UTF8String('stringtable')) then - newName := keyName + node.Name + UTF8String('-') - else newName := keyName; - AddNodes(node.Nodes[i], newName); - end; - if node.ValueAsString <> UTF8String('') then begin - Add(string(keyName + node.Name), string(node.ValueAsString)); - end; -end; procedure LoadLanguage(path:string); -var - document : TNativeXML; begin if (path = '') or (not FileExists(path)) then LoadEnglish() else begin tokenCount := 0; - - document := TNativeXML.Create; - document.LoadFromFile(path);; - if lowercase(string(document.EncodingString)) <> 'utf-8' then begin - AddNodes(document.Root, UTF8String('')); - end else begin // use easy xml because it supports utf-8 properly (at least...) + if true then begin parser := TParser.Create; ListXmlScanner := TEasyXmlScanner.Create(nil); diff --git a/Source/Core/XFormMan.pas b/Source/Core/XFormMan.pas index b7caa70..b66ab9d 100644 --- a/Source/Core/XFormMan.pas +++ b/Source/Core/XFormMan.pas @@ -33,6 +33,12 @@ interface var NumBuiltinVars: integer; +type + TFNToVN = record + FileName: string; + VarName: string; + end; + function NrVar: integer; function Varnames(const index: integer): String; procedure RegisterVariation(Variation: TVariationLoader; supports3D, supportsDC : boolean); @@ -45,6 +51,8 @@ function GetVariationIndexFromVariableNameIndex(const Index: integer): integer; procedure VarSupports(index : integer; var supports3D : boolean; var supportsDC : boolean); procedure InitializeXFormMan; procedure DestroyXFormMan; +procedure RegisterVariationFile(filename, name: string); +function GetFileNameOfVariation(name: string): string; implementation @@ -56,60 +64,48 @@ implementation VariableNames: TStringlist; loaderNum : integer; Variable2VariationIndex : array of integer; + FNToVNList : array of TFNToVN; + FNToVNCount: integer; procedure InitializeXFormMan; begin VariationList := TList.Create; VariableNames := TStringlist.create; SetLength(Variable2VariationIndex,0); + SetLength(FNToVNList, 0); + FNToVNCount := 0; end; procedure VarSupports(index : integer; var supports3D : boolean; var supportsDC : boolean); const supports3D_arr: array[0..NRLOCVAR-1] of boolean = ( - true, //'linear3D', - false, //'linear', - false, //'sinusoidal', - false, //'spherical', - false, //'swirl', - false, //'horseshoe', - false, //'polar', -// false, // 'handkerchief', -// false, // 'heart', - false, //'disc', - false, //'spiral', - false, //'hyperbolic', - false, //'diamond', -// false, // 'ex', -// false, // 'julia', -// false, // 'bent', -// false, // 'waves', -// false, // 'fisheye', -// false, // 'popcorn', -// false, // 'exponential', -// false, // 'power', -// false, // 'cosine', -// false, // 'rings', -// false, // 'fan', - false, //'eyefish', + true, //'linear', + true, //'flatten', + true, //'sinusoidal', + true, //'spherical', + true, //'swirl', + true, //'horseshoe', + true, //'polar', + true, //'disc', + true, //'spiral', + true, //'hyperbolic', + true, //'diamond', + true, //'eyefish', true, //'bubble', true, //'cylinder', - false, //'noise', - false, //'blur', - false, //'gaussian_blur', + true, //'noise', + true, //'blur', + true, //'gaussian_blur', true, //'zblur', true, //'blur3D', - true, //'pre_blur', true, //'pre_zscale', true, //'pre_ztranslate', true, //'pre_rotate_x', true, //'pre_rotate_y', - true, //'zscale', true, //'ztranslate', true, //'zcone', - true, //'post_rotate_x', true //'post_rotate_y', ); @@ -185,6 +181,7 @@ procedure DestroyXFormMan; VariationList.Free; Finalize(Variable2VariationIndex); + Finalize(FNToVNList); end; /////////////////////////////////////////////////////////////////////////////// @@ -206,8 +203,8 @@ function GetVariationIndexFromVariableNameIndex(const Index: integer): integer; function Varnames(const index: integer): String; const cvarnames: array[0..NRLOCVAR-1] of string = ( - 'linear3D', 'linear', + 'flatten', 'sinusoidal', 'spherical', 'swirl', @@ -270,11 +267,33 @@ function GetVariationIndex(const str: string): integer; end; /////////////////////////////////////////////////////////////////////////////// + +procedure RegisterVariationFile(filename, name: string); +begin + FNToVNCount := FNToVNCount + 1; + SetLength(FNToVNList, FNToVNCount); + FNToVNList[FNToVNCount - 1].FileName := filename; + FNToVNList[FNToVNCount - 1].VarName := name; +end; +function GetFileNameOfVariation(name: string): string; +var i: integer; +begin + for i := 0 to FNToVNCount - 1 do begin + if FNToVNList[i].VarName = name then begin + Result := FNToVNList[i].FileName; + Exit; + end; + end; + Result := ''; +end; + procedure RegisterVariation(Variation: TVariationLoader; supports3D, supportsDC : boolean); var i: integer; prevNumVariables:integer; begin + OutputDebugString(PChar(Variation.GetName)); + VariationList.Add(Variation); Variation.Supports3D := supports3D; Variation.SupportsDC := supportsDC; diff --git a/Source/Flame/ControlPoint.pas b/Source/Flame/ControlPoint.pas index aac8799..5769d19 100644 --- a/Source/Flame/ControlPoint.pas +++ b/Source/Flame/ControlPoint.pas @@ -29,7 +29,7 @@ interface uses Classes, Windows, Cmap, XForm, XFormMan, Binary, - SysUtils, math, ZLib; + SysUtils, math, ZLib, Bezier; const SUB_BATCH_SIZE = 10000; @@ -92,6 +92,8 @@ TControlPoint = class finalXformEnabled: boolean; useFinalXform: boolean; soloXform: integer; + curvePoints: array [0..3] of BezierPoints; + curveWeights: array [0..3] of BezierWeights; Transparency: boolean; @@ -101,6 +103,7 @@ TControlPoint = class xform: array[0..NXFORMS] of TXForm; + noLinearFix: boolean; variation: TVariation; cmap: TColorMap; cmapindex: integer; @@ -257,20 +260,30 @@ function sign(n: double): double; procedure TControlPoint.FillUsedPlugins; var - i, j, k : integer; + i, j, k, f : integer; v : double; s : String; begin used_plugins.Clear; - for i := 0 to Min(NumXForms+1, NXFORMS) do + + f := -1; if self.finalXformEnabled then f := 0; + //MessageBox(0, PCHAR(IntToStr(NumXForms + f)), PCHAR(''), 0); + + for i := 0 to Min(NumXForms+f, NXFORMS) do with xform[i] do begin for j := 0 to NRVAR - 1 do begin v := self.xform[i].GetVariation(j); - if (used_plugins.IndexOf(Varnames(j)) < 0) and (v <> 0) then - used_plugins.Add(Varnames(j)) + if (v <> 0) and // uses variation + (used_plugins.IndexOf(Varnames(j)) < 0) // not listed yet + then begin + used_plugins.Add(Varnames(j)); + s := s + Varnames(j) + ' on TX #' + IntToStr(i + 1) + #13#10; + end; end; end; + //MessageBox(0, PCHAR(s), PCHAR(''), MB_OK); + // Faulty... (* for i := 0 to NumXforms-1 do begin @@ -320,6 +333,14 @@ constructor TControlPoint.Create; background[1] := 0; background[2] := 0; + for i := 0 to 3 do + begin + curvePoints[i][0].x := 0.00; curvePoints[i][0].y := 0.00; curveWeights[i][0] := 1; + curvePoints[i][1].x := 0.00; curvePoints[i][1].y := 0.00; curveWeights[i][1] := 1; + curvePoints[i][2].x := 1.00; curvePoints[i][2].y := 1.00; curveWeights[i][2] := 1; + curvePoints[i][3].x := 1.00; curvePoints[i][3].y := 1.00; curveWeights[i][3] := 1; + end; + center[0] := 0; center[1] := 0; @@ -531,28 +552,13 @@ procedure TControlPoint.IterateXYC(NrPoints: integer; var Points: TPointsArray); i: Integer; p: TCPPoint; pPoint: PCPPoint; + depth: double; xf: TXform; begin -//{$if false} p.x := 2 * random - 1; p.y := 2 * random - 1; p.c := random; -//{$else} -{asm - fld1 - call System.@RandExt - fadd st, st - fsub st, st(1) - fstp qword ptr [p.x] - call System.@RandExt - fadd st, st - fsubrp st(1), st - fstp qword ptr [p.y] - call System.@RandExt - fstp qword ptr [p.c] -end; } -//{$ifend} try xf := xform[0];//random(NumXForms)]; @@ -568,23 +574,22 @@ procedure TControlPoint.IterateXYC(NrPoints: integer; var Points: TPointsArray); xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; xf.NextPoint(p); - if (xf.transOpacity = 0) then - pPoint^.x := MaxDouble // hack - else - finalXform.NextPointTo(p, pPoint^); + //if random >= xf.transOpacity then continue; + finalXform.NextPointTo(p, pPoint^); + ProjectionFunc(pPoint); + pPoint^.o := xf.transOpacity; Inc(pPoint); end else for i := 0 to NrPoints - 1 do begin xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; xf.NextPoint(p); - if (xf.transOpacity = 0) then - pPoint^.x := MaxDouble // hack - else begin - pPoint^ := p; - ProjectionFunc(pPoint); - end; + + //if random >= xf.transOpacity then continue; + pPoint^ := p; + ProjectionFunc(pPoint); + pPoint^.o := xf.transOpacity; Inc(pPoint); end; except @@ -602,6 +607,7 @@ procedure TControlPoint.ProjectNone(pPoint: PCPPoint); pPoint^.x := pPoint^.x / zr; pPoint^.y := pPoint^.y / zr; + pPoint^.z := pPoint^.z - CameraZpos; end; procedure TControlPoint.ProjectPitch(pPoint: PCPPoint); @@ -615,6 +621,7 @@ procedure TControlPoint.ProjectPitch(pPoint: PCPPoint); pPoint^.x := pPoint^.x / zr; pPoint^.y := y / zr; + pPoint^.z := pPoint^.z - CameraZpos; end; procedure TControlPoint.ProjectPitchYaw(pPoint: PCPPoint); @@ -629,6 +636,7 @@ procedure TControlPoint.ProjectPitchYaw(pPoint: PCPPoint); pPoint^.x := x / zr; pPoint^.y := y / zr; + pPoint^.z := pPoint^.z - CameraZpos; end; procedure TControlPoint.ProjectPitchDOF(pPoint: PCPPoint); @@ -694,6 +702,7 @@ procedure TControlPoint.ProjectPitchDOF(pPoint: PCPPoint); pPoint^.x := (pPoint^.x + dr*dcos) / zr; pPoint^.y := (y + dr*dsin) / zr; + pPoint^.z := pPoint^.z - CameraZpos; end; procedure TControlPoint.ProjectPitchYawDOF(pPoint: PCPPoint); @@ -759,6 +768,7 @@ procedure TControlPoint.ProjectPitchYawDOF(pPoint: PCPPoint); pPoint^.x := (x + dr*dcos) / zr; pPoint^.y := (y + dr*dsin) / zr; + pPoint^.z := pPoint^.z - CameraZpos; end; { @@ -996,6 +1006,22 @@ procedure TControlPoint.ParseString(aString: string); except on EConvertError do background[2] := 0; end; + end else if AnsiCompareText(CurrentToken, 'curves') = 0 then begin + for i := 0 to 3 do + begin + Inc(ParsePos);curvePoints[i][0].x := StrToFloat(ParseValues[ParsePos]); + Inc(ParsePos);curvePoints[i][0].y := StrToFloat(ParseValues[ParsePos]); + Inc(ParsePos);curveWeights[i][0] := StrToFloat(ParseValues[ParsePos]); + Inc(ParsePos);curvePoints[i][1].x := StrToFloat(ParseValues[ParsePos]); + Inc(ParsePos);curvePoints[i][1].y := StrToFloat(ParseValues[ParsePos]); + Inc(ParsePos);curveWeights[i][1] := StrToFloat(ParseValues[ParsePos]); + Inc(ParsePos);curvePoints[i][2].x := StrToFloat(ParseValues[ParsePos]); + Inc(ParsePos);curvePoints[i][2].y := StrToFloat(ParseValues[ParsePos]); + Inc(ParsePos);curveWeights[i][2] := StrToFloat(ParseValues[ParsePos]); + Inc(ParsePos);curvePoints[i][3].x := StrToFloat(ParseValues[ParsePos]); + Inc(ParsePos);curvePoints[i][3].y := StrToFloat(ParseValues[ParsePos]); + Inc(ParsePos);curveWeights[i][3] := StrToFloat(ParseValues[ParsePos]); + end; end else if AnsiCompareText(CurrentToken, 'pulse') = 0 then begin Inc(ParsePos); pulse[0, 0] := StrToFloat(ParseValues[ParsePos]); @@ -1092,7 +1118,7 @@ procedure TControlPoint.ParseString(aString: string); while true do begin if (ParsePos + 1) >= ParseValues.Count then break; - if ParseValues[ParsePos + 1][1] in ['a'..'z', 'A'..'Z'] then + if CharInSet(ParseValues[ParsePos + 1][1], ['a'..'z', 'A'..'Z']) then break; Inc(ParsePos); @@ -1114,7 +1140,7 @@ procedure TControlPoint.ParseString(aString: string); while true do begin if (ParsePos + 1) >= ParseValues.Count then break; - if ParseValues[ParsePos + 1][1] in ['a'..'z', 'A'..'Z'] then + if CharInSet(ParseValues[ParsePos + 1][1], ['a'..'z', 'A'..'Z']) then break; Inc(ParsePos); @@ -1128,7 +1154,7 @@ procedure TControlPoint.ParseString(aString: string); while true do begin if (ParsePos + 1) >= ParseValues.Count then break; - if ParseValues[ParsePos + 1][1] in ['a'..'z', 'A'..'Z'] then + if CharInSet(ParseValues[ParsePos + 1][1], ['a'..'z', 'A'..'Z']) then break; Inc(ParsePos); @@ -1823,6 +1849,7 @@ procedure TControlPoint.SaveToStringlist(sl: TStringlist); OldDecimalSperator: Char; v: double; str: string; + curves: string; begin OldDecimalSperator := DecimalSeparator; DecimalSeparator := '.'; @@ -1839,6 +1866,28 @@ procedure TControlPoint.SaveToStringlist(sl: TStringlist); sl.add(format('cam_zpos %g', [cameraZpos])); sl.add(format('cam_dof %g', [cameraDOF])); + for i := 0 to 3 do + begin + curves := curves + FloatToStr(curvePoints[i][0].x) + ' '; + curves := curves + FloatToStr(curvePoints[i][0].y) + ' '; + curves := curves + FloatToStr(curveWeights[i][0]) + ' '; + + curves := curves + FloatToStr(curvePoints[i][1].x) + ' '; + curves := curves + FloatToStr(curvePoints[i][1].y) + ' '; + curves := curves + FloatToStr(curveWeights[i][1]) + ' '; + + curves := curves + FloatToStr(curvePoints[i][2].x) + ' '; + curves := curves + FloatToStr(curvePoints[i][2].y) + ' '; + curves := curves + FloatToStr(curveWeights[i][2]) + ' '; + + curves := curves + FloatToStr(curvePoints[i][3].x) + ' '; + curves := curves + FloatToStr(curvePoints[i][3].y) + ' '; + curves := curves + FloatToStr(curveWeights[i][3]) + ' '; + end; + + curves := trim(curves); + sl.Add(Format('curves %s', [curves])); + sl.add(format('image_size %d %d center %g %g pixels_per_unit %f', [Width, Height, center[0], center[1], pixels_per_unit])); sl.add(format('spatial_oversample %d spatial_filter_radius %f', @@ -2128,7 +2177,7 @@ procedure TControlPoint.SaveToBinary(const handle: File); function TControlPoint.Clone: TControlPoint; var - i: integer; + i, j: integer; sl: TStringList; begin sl := TStringList.Create; @@ -2148,6 +2197,17 @@ function TControlPoint.Clone: TControlPoint; Result.enable_de := enable_de; Result.xdata := xdata; + Result.Background[0] := background[0]; + Result.Background[1] := background[1]; + Result.Background[2] := background[2]; + + for i := 0 to 3 do + for j := 0 to 3 do begin + Result.CurveWeights[i,j] := curveWeights[i,j]; + Result.curvePoints[i,j].x := curvePoints[i,j].x; + Result.curvePoints[i,j].y := curvePoints[i,j].y; + end; + result.used_plugins.Clear; for i := 0 to used_plugins.Count-1 do Result.used_plugins.Add(used_plugins[i]); @@ -2160,7 +2220,7 @@ function TControlPoint.Clone: TControlPoint; procedure TControlPoint.Copy(cp1: TControlPoint; KeepSizes: boolean = false); var - i: integer; + i, j: integer; sl: TStringList; w, h: integer; begin @@ -2190,6 +2250,17 @@ procedure TControlPoint.Copy(cp1: TControlPoint; KeepSizes: boolean = false); used_plugins := cp1.used_plugins; xdata := cp1.xdata; + background[0] := cp1.background[0]; + background[1] := cp1.background[1]; + background[2] := cp1.background[2]; + + for i := 0 to 3 do + for j := 0 to 3 do begin + CurveWeights[i,j] := cp1.curveWeights[i,j]; + curvePoints[i,j].x := cp1.curvePoints[i,j].x; + curvePoints[i,j].y := cp1.curvePoints[i,j].y; + end; + if KeepSizes then AdjustScale(w, h); @@ -2227,6 +2298,15 @@ procedure TControlPoint.Clear; for i := 0 to NXFORMS do xform[i].Clear; FinalXformEnabled := false; soloxform := -1; + + for i := 0 to 3 do + begin + curvePoints[i][0].x := 0.00; curvePoints[i][0].y := 0.00; curveWeights[i][0] := 1; + curvePoints[i][1].x := 0.00; curvePoints[i][1].y := 0.00; curveWeights[i][1] := 1; + curvePoints[i][2].x := 1.00; curvePoints[i][2].y := 1.00; curveWeights[i][2] := 1; + curvePoints[i][3].x := 1.00; curvePoints[i][3].y := 1.00; curveWeights[i][3] := 1; + end; + try if (used_plugins <> nil) then used_plugins.Clear diff --git a/Source/Flame/XForm.pas b/Source/Flame/XForm.pas index 9bdc7d5..42bbc79 100644 --- a/Source/Flame/XForm.pas +++ b/Source/Flame/XForm.pas @@ -30,6 +30,10 @@ interface uses +{$ifdef Apo7X64} +{$else} +AsmRandom, +{$endif} XFormMan, BaseVariation; const @@ -46,7 +50,7 @@ interface type TCPpoint = record - x, y, z, c: double; + x, y, z, c, o: double; end; PCPpoint = ^TCPpoint; @@ -61,7 +65,10 @@ T2Cpoint = record TMatrix = array[0..2, 0..2] of double; -{$define _ASM_} +{$ifdef Apo7X64} +{$else} + //{$define _ASM_} +{$endif} type TXForm = class @@ -167,7 +174,7 @@ TXForm = class procedure PreRotateX; procedure PreRotateY; - procedure Linear; + procedure Flatten; procedure ZScale; procedure ZTranslate; procedure ZCone; @@ -218,7 +225,7 @@ TXForm = class implementation uses - SysUtils, Math, StrUtils, AsmRandom; + SysUtils, Math, StrUtils; const EPS: double = 1E-300; @@ -241,14 +248,6 @@ procedure TXForm.SetVariation(index : integer; value : double); vars[index] := value; end; -procedure SinCos(const Theta: double; var Sin, Cos: double); // to avoid using 'extended' type -asm - FLD Theta - FSINCOS - FSTP qword ptr [edx] // Cos - FSTP qword ptr [eax] // Sin - FWAIT -end; { TXForm } @@ -364,7 +363,9 @@ procedure TXForm.Prepare; // Normal variations for i := 0 to NrVar - 1 do begin if (vars[i] <> 0.0) then begin - if (LeftStr(Varnames(i), 4) = 'pre_') or (LeftStr(Varnames(i), 5) = 'post_') then continue; + if (LeftStr(Varnames(i), 4) = 'pre_') or + (LeftStr(Varnames(i), 5) = 'post_') or + (Varnames(i) = 'flatten') then continue; FCalcFunctionList[FNrFunctions] := FFunctionList[i]; Inc(FNrFunctions); @@ -373,7 +374,9 @@ procedure TXForm.Prepare; // Post- variations for i := 0 to NrVar - 1 do begin - if (vars[i] <> 0.0) and (LeftStr(Varnames(i), 5) = 'post_') then begin + if (vars[i] <> 0.0) and ( + (LeftStr(Varnames(i), 5) = 'post_') or + (Varnames(i) = 'flatten')) then begin FCalcFunctionList[FNrFunctions] := FFunctionList[i]; Inc(FNrFunctions); end; @@ -605,25 +608,9 @@ procedure TXForm.Linear3D; end; /////////////////////////////////////////////////////////////////////////////// -procedure TXForm.Linear; -{$ifndef _ASM_} +procedure TXForm.Flatten; begin - FPx := FPx + vars[1] * FTx; - FPy := FPy + vars[1] * FTy; -{$else} -asm - mov edx, [eax + vars] - fld qword ptr [edx + 1*8] - fld qword ptr [eax + FTx] - fmul st, st(1) - fadd qword ptr [eax + FPx] - fstp qword ptr [eax + FPx] - fld qword ptr [eax + FTy] - fmulp - fadd qword ptr [eax + FPy] - fstp qword ptr [eax + FPy] - fwait -{$endif} + FPz := 0; end; //--1--//////////////////////////////////////////////////////////////////////// @@ -632,10 +619,15 @@ procedure TXForm.Sinusoidal; begin FPx := FPx + vars[2] * sin(FTx); FPy := FPy + vars[2] * sin(FTy); + FPz := FPz + FTz * vars[2]; {$else} asm mov edx, [eax + vars] fld qword ptr [edx + 2*8] + fld qword ptr [eax + FTz] + fmul st, st(1) + fadd qword ptr [eax + FPz] + fstp qword ptr [eax + FPz] fld qword ptr [eax + FTx] fsin fmul st, st(1) @@ -659,8 +651,17 @@ procedure TXForm.Spherical; r := vars[3] / (sqr(FTx) + sqr(FTy) + EPS); FPx := FPx + FTx * r; FPy := FPy + FTy * r; + FPz := FPz + FTz * vars[3]; {$else} asm + mov edx, [eax + vars] + fld qword ptr [edx + 3*8] + fld qword ptr [eax + FTz] + fmul st, st(1) + fadd qword ptr [eax + FPz] + fstp qword ptr [eax + FPz] + fstp st + fld qword ptr [eax + FTy] fld qword ptr [eax + FTx] fld st(1) @@ -669,7 +670,6 @@ procedure TXForm.Spherical; fmul st, st faddp fadd qword ptr [EPS] - mov edx, [eax + vars] fdivr qword ptr [edx + 3*8] fmul st(2), st fmulp @@ -683,204 +683,34 @@ procedure TXForm.Spherical; //--3--//////////////////////////////////////////////////////////////////////// procedure TXForm.Swirl; -{$ifndef _ASM_} -{ - r2 := FTx * FTx + FTy * FTy; - c1 := sin(r2); - c2 := cos(r2); - FPx := FPx + vars[3] * (c1 * FTx - c2 * FTy); - FPy := FPy + vars[3] * (c2 * FTx + c1 * FTy); -} var sinr, cosr: double; begin SinCos(sqr(FTx) + sqr(FTy), sinr, cosr); FPx := FPx + vars[4] * (sinr * FTx - cosr * FTy); FPy := FPy + vars[4] * (cosr * FTx + sinr * FTy); -{$else} -asm - mov edx, [eax + vars] - fld qword ptr [edx + 4*8] - fld qword ptr [eax + FTy] - fld qword ptr [eax + FTx] - fld st(1) - fmul st, st - fld st(1) - fmul st, st - faddp - fsincos - fld st(1) - fmul st, st(3) - fld st(1) - fmul st, st(5) - fsubp st(1), st - fmul st, st(5) - fadd qword ptr [eax + FPx] - fstp qword ptr [eax + FPx] - fmulp st(2), st - fmulp st(2), st - faddp - fmulp - fadd qword ptr [eax + FPy] - fstp qword ptr [eax + FPy] - fwait -{$endif} + FPz := FPz + FTz * vars[4]; end; //--4--//////////////////////////////////////////////////////////////////////// procedure TXForm.Horseshoe; -{$ifndef _ASM_} -// --Z-- he he he... -// FTx/FLength FTy/FLength -// FPx := FPx + vars[4] * (FSinA * FTx - FCosA * FTy); -// FPy := FPy + vars[4] * (FCosA* FTx + FSinA * FTy); var r: double; begin r := vars[5] / (sqrt(sqr(FTx) + sqr(FTy)) + EPS); FPx := FPx + (FTx - FTy) * (FTx + FTy) * r; FPy := FPy + (2*FTx*FTy) * r; -{$else} -asm - fld qword ptr [eax + FTx] - fld qword ptr [eax + FTy] - fld st(1) - fmul st, st - fld st(1) - fmul st, st - faddp - fsqrt - fadd qword ptr [EPS] - mov edx, [eax + vars] - fdivr qword ptr [edx + 5*8] - fld st(2) - fadd st, st(2) - fld st(3) - fsub st, st(3) - fmulp - fmul st, st(1) - fadd qword ptr [eax + FPx] - fstp qword ptr [eax + FPx] - fmulp - fmulp - fadd st, st - fadd qword ptr [eax + FPy] - fstp qword ptr [eax + FPy] - fwait -{$endif} + FPz := FPz + FTz * vars[5]; end; //--5--//////////////////////////////////////////////////////////////////////// procedure TXForm.Polar; -{$ifndef _ASM_} -{ -var - ny: double; - rPI: double; -begin - rPI := 0.31830989; - ny := sqrt(FTx * FTx + FTy * FTy) - 1.0; - FPx := FPx + vars[5] * (FAngle*rPI); - FPy := FPy + vars[5] * ny; -} begin FPx := FPx + polar_vpi * FAngle; //vars[5] * FAngle / PI; FPy := FPy + vars[6] * (sqrt(sqr(FTx) + sqr(FTy)) - 1.0); -{$else} -asm - fld qword ptr [eax + FAngle] - fmul qword ptr [eax + polar_vpi] - fadd qword ptr [eax + FPx] - fstp qword ptr [eax + FPx] - fld qword ptr [eax + FTx] - fmul st, st - fld qword ptr [eax + FTy] - fmul st, st - faddp - fsqrt - fld1 - fsubp st(1), st - mov edx, [eax + vars] - fmul qword ptr [edx + 6*8] - fadd qword ptr [eax + FPy] - fstp qword ptr [eax + FPy] - fwait -{$endif} -end; - -(* -//--6--//////////////////////////////////////////////////////////////////////// -procedure TXForm.FoldedHandkerchief; -{$ifndef _ASM_} -var - r: double; -begin - r := sqrt(sqr(FTx) + sqr(FTy)); - FPx := FPx + vars[6] * sin(FAngle + r) * r; - FPy := FPy + vars[6] * cos(FAngle - r) * r; -{$else} -asm - mov edx, [eax + vars] - fld qword ptr [edx + 6*8] - fld qword ptr [eax + FTx] - fmul st, st - fld qword ptr [eax + FTy] - fmul st, st - faddp - fsqrt - fld qword ptr [eax + FAngle] - fld st - fadd st, st(2) - fsin - fmul st, st(2) - fmul st, st(3) - fadd qword ptr [eax + FPx] - fstp qword ptr [eax + FPx] - fsub st, st(1) - fcos - fmulp - fmulp - fadd qword ptr [eax + FPy] - fstp qword ptr [eax + FPy] - fwait -{$endif} + FPz := FPz + FTz * vars[6]; end; -//--7--//////////////////////////////////////////////////////////////////////// -procedure TXForm.Heart; -{$ifndef _ASM_} -var - r, sinr, cosr: double; -begin - r := sqrt(sqr(FTx) + sqr(FTy)); - Sincos(r*FAngle, sinr, cosr); - r := r * vars[7]; - FPx := FPx + r * sinr; - FPy := FPy - r * cosr; -{$else} -asm - mov edx, [eax + vars] - fld qword ptr [edx + 7*8] - fld qword ptr [eax + FTx] - fmul st, st - fld qword ptr [eax + FTy] - fmul st, st - faddp - fsqrt - fmul st(1), st - fmul qword ptr [eax + FAngle] - fsincos - fmul st, st(2) - fsubr qword ptr [eax + FPy] - fstp qword ptr [eax + FPy] - fmulp - fadd qword ptr [eax + FPx] - fstp qword ptr [eax + FPx] - fwait -{$endif} -end; -*) - //--6--//////////////////////////////////////////////////////////////////////// procedure TXForm.Disc; {$ifndef _ASM_} @@ -891,14 +721,19 @@ procedure TXForm.Disc; r := disc_vpi * FAngle; //vars[7] * FAngle / PI; FPx := FPx + sinr * r; FPy := FPy + cosr * r; + FPz := FPz + FTz * vars[7]; {$else} asm + mov edx, [eax + vars] + fld qword ptr [edx + 7*8] + fld qword ptr [eax + FTz] + fmul st, st(1) + fadd qword ptr [eax + FPz] + fstp qword ptr [eax + FPz] + fstp st + fld qword ptr [eax + disc_vpi] -// mov edx, [eax + vars] -// fld qword ptr [edx + 7*8] fmul qword ptr [eax + FAngle] -// fldpi -// fdivp st(1), st fld qword ptr [eax + FTx] fmul st, st fld qword ptr [eax + FTy] @@ -920,7 +755,6 @@ procedure TXForm.Disc; //--7--//////////////////////////////////////////////////////////////////////// procedure TXForm.Spiral; -{$ifndef _ASM_} var r, sinr, cosr: double; begin @@ -929,743 +763,66 @@ procedure TXForm.Spiral; r := vars[8] / r; FPx := FPx + (FCosA + sinr) * r; FPy := FPy + (FsinA - cosr) * r; -{$else} -asm - mov edx, [eax + vars] - fld qword ptr [edx + 8*8] - fld qword ptr [eax + FLength] - fadd qword ptr [EPS] - fdiv st(1), st - fsincos - fsubr qword ptr [eax + FSinA] - fmul st, st(2) - fadd qword ptr [eax + FPy] - fstp qword ptr [eax + FPy] - fadd qword ptr [eax + FCosA] - fmulp - fadd qword ptr [eax + FPx] - fstp qword ptr [eax + FPx] - fwait -{$endif} + FPz := FPz + FTz * vars[8]; end; //--10--/////////////////////////////////////////////////////////////////////// procedure TXForm.Hyperbolic; -{$ifndef _ASM_} -{ -var - r: double; -begin - r := Flength + 1E-6; - FPx := FPx + vars[10] * FSinA / r; - FPy := FPy + vars[10] * FCosA * r; -} -// --Z-- Yikes!!! SOMEONE SHOULD GO BACK TO SCHOOL!!!!!!! -// Now watch and learn how to do this WITHOUT calculating sin and cos: begin FPx := FPx + vars[9] * FTx / (sqr(FTx) + sqr(FTy) + EPS); FPy := FPy + vars[9] * FTy; -{$else} -asm - mov edx, [eax + vars] - fld qword ptr [edx + 9*8] - fld qword ptr [eax + FTy] - fld qword ptr [eax + FTx] - fld st(1) - fmul st, st - fld st(1) - fmul st, st - faddp - fadd qword ptr [EPS] - fdivp st(1), st - fmul st, st(2) - fadd qword ptr [eax + FPx] - fstp qword ptr [eax + FPx] - fmulp - fadd qword ptr [eax + FPy] - fstp qword ptr [eax + FPy] - fwait -{$endif} + FPz := FPz + FTz * vars[9]; end; //--11--/////////////////////////////////////////////////////////////////////// procedure TXForm.Square; -{$ifndef _ASM_} var sinr, cosr: double; begin SinCos(FLength, sinr, cosr); FPx := FPx + vars[10] * FSinA * cosr; FPy := FPy + vars[10] * FCosA * sinr; -{$else} -asm - mov edx, [eax + vars] - fld qword ptr [edx + 10*8] - fld qword ptr [eax + FLength] - fsincos - fmul qword ptr [eax + FSinA] - fmul st, st(2) - fadd qword ptr [eax + FPx] - fstp qword ptr [eax + FPx] - fmul qword ptr [eax + FCosA] - fmulp - fadd qword ptr [eax + FPy] - fstp qword ptr [eax + FPy] - fwait -{$endif} + FPz := FPz + FTz * vars[10]; end; -(* //--12--/////////////////////////////////////////////////////////////////////// -procedure TXForm.Ex; +procedure TXForm.Eyefish; +var + r: double; +begin + r := 2 * vars[11] / (sqrt(sqr(FTx) + sqr(FTy)) + 1); + FPx := FPx + r * FTx; + FPy := FPy + r * FTy; + FPz := FPz + FTz * vars[11]; +end; + +/////////////////////////////////////////////////////////////////////////////// +procedure TXForm.Bubble; {$ifndef _ASM_} var r: double; - n0, n1, m0, m1: double; begin - r := sqrt(sqr(FTx) + sqr(FTy)); - n0 := sin(FAngle + r); - n1 := cos(FAngle - r); - m0 := sqr(n0) * n0; - m1 := sqr(n1) * n1; - r := r * vars[12]; - FPx := FPx + r * (m0 + m1); - FPy := FPy + r * (m0 - m1); + r := (sqr(FTx) + sqr(FTy))/4 + 1; + FPz := FPz + vars[12] * (2 / r - 1); + + r := vars[12] / r; + + FPx := FPx + r * FTx; + FPy := FPy + r * FTy; {$else} asm + fld qword ptr [eax + FTy] fld qword ptr [eax + FTx] + fld st(1) fmul st, st - fld qword ptr [eax + FTy] + fld st(1) fmul st, st faddp - fsqrt - fld qword ptr [eax + FAngle] - fld st - fadd st, st(2) - fsin - fld st - fld st - fmulp - fmulp - fxch st(1) - fsub st, st(2) - fcos - fld st - fld st - fmulp - fmulp - mov edx, [eax + vars] - fld qword ptr [edx + 12*8] - fmulp st(3), st - fld st - fadd st, st(2) - fmul st, st(3) - fadd qword ptr [eax + FPx] - fstp qword ptr [eax + FPx] - fsubp st(1), st - fmulp - fadd qword ptr [eax + FPy] - fstp qword ptr [eax + FPy] - fwait -{$endif} -end; - -//--13--/////////////////////////////////////////////////////////////////////// -procedure TXForm.Julia; -{$ifndef _ASM_} -var - r, sina, cosa: double; -begin - SinCos(FAngle/2 + pi*random(2), sina, cosa); - r := vars[13] * sqrt(sqrt(sqr(FTx) + sqr(FTy))); - FPx := FPx + r * cosa; - FPy := FPy + r * sina; -{$else} -asm - fld qword ptr [ebx + FAngle] // assert: self is in ebx - fld1 - fld1 - faddp - fdivp st(1), st - mov eax, 2 - call System.@RandInt - - shr eax, 1 - jnc @skip - fldpi - faddp -@skip: -{ - push eax - fild dword ptr [esp] - add esp, 4 - fldpi - fmulp - faddp -} - fsincos - fld qword ptr [ebx + FTx] - fmul st, st - fld qword ptr [ebx + FTy] - fmul st, st - faddp - fsqrt - fsqrt - mov edx, [ebx + vars] - fmul qword ptr [edx + 13*8] - fmul st(2), st - fmulp st(1), st - fadd qword ptr [ebx + FPx] - fstp qword ptr [ebx + FPx] - fadd qword ptr [ebx + FPy] - fstp qword ptr [ebx + FPy] - fwait -{$endif} -end; - -//--14--/////////////////////////////////////////////////////////////////////// -procedure TXForm.Bent; -{$ifndef _ASM_} -{ -var - nx, ny: double; -begin - nx := FTx; - ny := FTy; - if (nx < 0) and (nx > -1E100) then - nx := nx * 2; - if ny < 0 then - ny := ny / 2; - FPx := FPx + vars[14] * nx; - FPy := FPy + vars[14] * ny; -} -// --Z-- This variation is kinda weird... -begin - if FTx < 0 then - FPx := FPx + vars[14] * (FTx*2) - else - FPx := FPx + vars[14] * FTx; - if FTy < 0 then - FPy := FPy + vars[14] * (FTy/2) - else - FPy := FPy + vars[14] * FTy; -{$else} -// haven't noticed any improvement here... :-/ -asm - mov edx, [eax + vars] - fld qword ptr [edx + 14*8] - fld qword ptr [ebx + FTx] - ftst - fstsw ax - sahf - ja @posx - fadd st, st -@posx: - fmul st, st(1) - fadd qword ptr [ebx + FPx] - fstp qword ptr [ebx + FPx] - fld qword ptr [ebx + FTy] - ftst - fstsw ax - sahf - ja @posy - fld1 - fadd st, st - fdivp st(1), st -@posy: - fmulp - fadd qword ptr [ebx + FPy] - fstp qword ptr [ebx + FPy] - fwait -{$endif} -end; - -//--15--/////////////////////////////////////////////////////////////////////// -procedure TXForm.Waves; -{$ifndef _ASM_} -{ -var - dx,dy,nx,ny: double; -begin - dx := c20; - dy := c21; - nx := FTx + c10 * sin(FTy / ((dx * dx) + EPS)); - ny := FTy + c11 * sin(FTx / ((dy * dy) + EPS)); - FPx := FPx + vars[15] * nx; - FPy := FPy + vars[15] * ny; -} -begin - //FPx := FPx + vars[15] * (FTx + c10 * sin(FTy / (sqr(c20) + EPS))); - //FPy := FPy + vars[15] * (FTy + c11 * sin(FTx / (sqr(c21) + EPS))); - FPx := FPx + vars[15] * (FTx + c10 * sin(FTy * waves_f1)); - FPy := FPy + vars[15] * (FTy + c11 * sin(FTx * waves_f2)); -{$else} -asm - mov edx, [eax + vars] - fld qword ptr [edx + 15*8] - fld qword ptr [eax + FTy] - fld qword ptr [eax + FTx] - fld st(1) - fmul qword ptr [eax + waves_f1] - fsin - fmul qword ptr [eax + c10] - fadd st, st(1) - fmul st, st(3) - fadd qword ptr [eax + FPx] - fstp qword ptr [eax + FPx] - fmul qword ptr [eax + waves_f2] - fsin - fmul qword ptr [eax + c11] - faddp - fmulp - fadd qword ptr [eax + FPy] - fstp qword ptr [eax + FPy] - fwait -{$endif} -end; - -//--16--/////////////////////////////////////////////////////////////////////// -procedure TXForm.Fisheye; -{$ifndef _ASM_} -var - r: double; -begin -{ -// r := sqrt(FTx * FTx + FTy * FTy); -// a := arctan2(FTx, FTy); -// r := 2 * r / (r + 1); - r := 2 * Flength / (Flength + 1); - FPx := FPx + vars[16] * r * FCosA; - FPy := FPy + vars[16] * r * FSinA; -} -// --Z-- and again, sin & cos are NOT necessary here: - r := 2 * vars[16] / (sqrt(sqr(FTx) + sqr(FTy)) + 1); -// by the way, now we can clearly see that the original author messed X and Y: - FPx := FPx + r * FTy; - FPy := FPy + r * FTx; -{$else} -asm - mov edx, [eax + vars] - fld qword ptr [edx + 16*8] - fadd st, st - fld qword ptr [eax + FTx] - fld qword ptr [eax + FTy] - fld st(1) - fmul st, st - fld st(1) - fmul st, st - faddp - fsqrt - fld1 - faddp - fdivp st(3), st - fmul st, st(2) - fadd qword ptr [eax + FPx] - fstp qword ptr [eax + FPx] - fmulp - fadd qword ptr [eax + FPy] - fstp qword ptr [eax + FPy] - fwait -{$endif} -end; - -//--17--/////////////////////////////////////////////////////////////////////// -procedure TXForm.Popcorn; -{$ifndef _ASM_} -var - dx, dy: double; -// nx, ny: double; -begin - dx := tan(3 * FTy); - if (dx <> dx) then - dx := 0.0; // < probably won't work in Delphi - dy := tan(3 * FTx); // NAN will raise an exception... - if (dy <> dy) then - dy := 0.0; // remove for speed? -// nx := FTx + c20 * sin(dx); -// ny := FTy + c21 * sin(dy); -// FPx := FPx + vars[17] * nx; -// FPy := FPy + vars[17] * ny; - FPx := FPx + vars[17] * (FTx + c20 * sin(dx)); - FPy := FPy + vars[17] * (FTy + c21 * sin(dy)); -{$else} -asm - mov edx, [eax + vars] - fld qword ptr [edx + 17*8] - fld qword ptr [eax + FTy] - fld qword ptr [eax + FTx] - fld st(1) - fld st - fld st - faddp - faddp - fptan - fstp st - fsin - fmul qword ptr [eax + c20] - fadd st, st(1) - fmul st, st(3) - fadd qword ptr [ebx + FPx] - fstp qword ptr [ebx + FPx] - fld st - fld st - faddp - faddp - fptan - fstp st - fsin - fmul qword ptr [eax + c21] - faddp - fmulp - fadd qword ptr [ebx + FPy] - fstp qword ptr [ebx + FPy] - fwait -{$endif} -end; - -//--18--/////////////////////////////////////////////////////////////////////// -procedure TXForm.Exponential; -{$ifndef _ASM_} -var - d: double; - sinr, cosr: double; -begin - SinCos(PI * FTy, sinr, cosr); - d := vars[18] * exp(FTx - 1); // --Z-- (e^x)/e = e^(x-1) - FPx := FPx + cosr * d; - FPy := FPy + sinr * d; -{$else} -asm - fld qword ptr [eax + FTx] - fld1 - fsubp st(1), st -// --Z-- here goes exp(x) code from System.pas - FLDL2E - FMUL - FLD ST(0) - FRNDINT - FSUB ST(1), ST - FXCH ST(1) - F2XM1 - FLD1 - FADD - FSCALE - FSTP ST(1) -// ----- - mov edx, [eax + vars] - fmul qword ptr [edx + 18*8] - fld qword ptr [eax + FTy] - fldpi - fmulp - fsincos - fmul st, st(2) - fadd qword ptr [ebx + FPx] - fstp qword ptr [ebx + FPx] - fmulp - fadd qword ptr [ebx + FPy] - fstp qword ptr [ebx + FPy] - fwait -{$endif} -end; - -//--19--/////////////////////////////////////////////////////////////////////// -procedure TXForm.Power; -{$ifndef _ASM_} -var - r: double; -begin - r := vars[19] * Math.Power(FLength, FSinA); - FPx := FPx + r * FCosA; - FPy := FPy + r * FSinA; -{$else} -// --Z-- x^y = 2^(y*log2(x)) -asm - fld qword ptr [ebx + FSinA] - fld st - fld qword ptr [ebx + FLength] - fyl2x - fld st - frndint - fsub st(1), st - fxch st(1) - f2xm1 - fld1 - fadd - fscale - fstp st(1) - mov edx, [eax + vars] - fmul qword ptr [edx + 19*8] - fmul st(1), st - fmul qword ptr [ebx + FCosA] - fadd qword ptr [ebx + FPx] - fstp qword ptr [ebx + FPx] - fadd qword ptr [ebx + FPy] - fstp qword ptr [ebx + FPy] - fwait -{$endif} -end; - -//--20--/////////////////////////////////////////////////////////////////////// -procedure TXForm.Cosine; -{$ifndef _ASM_} -var - sinr, cosr: double; - e1, e2: double; -begin -// SinCos(FTx * PI, sinr, cosr); -// FPx := FPx + vars[20] * cosr * cosh(FTy); -// FPy := FPy - vars[20] * sinr * sinh(FTy); - SinCos(FTx * PI, sinr, cosr); - if FTy = 0 then - begin - // sinh(0) = 0, cosh(0) = 1 - FPx := FPx + vars[20] * cosr; - end - else begin - // --Z-- sinh() and cosh() both calculate exp(y) and exp(-y) - e1 := exp(FTy); - e2 := exp(-FTy); - FPx := FPx + vars[20] * cosr * (e1 + e2)/2; - FPy := FPy - vars[20] * sinr * (e1 - e2)/2; - end; -{$else} -asm - fld qword ptr [eax + FTx] - fldpi - fmulp - fsincos - fld qword ptr [eax + cosine_var2] - fmul st(2), st - fmulp - fld qword ptr [eax + FTy] -// --Z-- here goes exp(x) modified to compute both exp(x) and exp(-x) - FLDL2E - FMUL - FLD ST(0) - FRNDINT - FSUB ST(1), ST - fld st - fchs - fld st(2) - fchs - F2XM1 - FLD1 - FADD - FSCALE - FSTP ST(1) - fxch st(2) - F2XM1 - FLD1 - FADD - FSCALE - FST ST(1) -// ----- - fadd st, st(2) - fmulp st(3), st - fsubp st(1), st - fmulp st(2), st - fadd qword ptr [ebx + FPx] - fstp qword ptr [ebx + FPx] - fadd qword ptr [ebx + FPy] // "add" because: - fstp qword ptr [ebx + FPy] // FPy := FPy + vars[20] * sinr * (e2 - e1)/2; - fwait -{$endif} -end; - -//--21--/////////////////////////////////////////////////////////////////////// -procedure TXForm.Rings; -{$ifndef _ASM_} -var - r: double; - //dx: double; -begin - //dx := sqr(c20) + EPS; -// r := FLength; -// r := r + dx - System.Int((r + dx)/(2 * dx)) * 2 * dx - dx + r * (1-dx); -// --Z-- ^^^^ heheeeee :-) ^^^^ - - r := vars[21] * ( - 2 * FLength - rings_dx * (System.Int((FLength/rings_dx + 1)/2) * 2 + FLength) - ); - FPx := FPx + r * FCosA; - FPy := FPy + r * FSinA; -{$else} -asm - fld qword ptr [eax + FLength] - fld qword ptr [eax + rings_dx] - fld st(1) - fdiv st, st(1) - fld1 - faddp - fld1 - fld1 - faddp - fdivp st(1), st - call System.@Int - fadd st, st - fadd st, st(2) - fmulp - fsub st, st(1) - fsubp st(1), st - mov edx, [eax + vars] - fmul qword ptr [edx + 21*8] - fld st - fmul qword ptr [eax + FCosA] - fadd qword ptr [ebx + FPx] - fstp qword ptr [ebx + FPx] - fmul qword ptr [eax + FSinA] - fadd qword ptr [ebx + FPy] - fstp qword ptr [ebx + FPy] - fwait -{$endif} -end; - -//--22--/////////////////////////////////////////////////////////////////////// -procedure TXForm.Fan; -{$ifndef _ASM_} -var - r, a : double; - sinr, cosr: double; - //dx, dy, dx2: double; -begin - //dy := c21; - //dx := PI * (sqr(c20) + EPS); - //dx2 := dx/2; - -// if (FAngle+c21 - System.Int((FAngle + c21)/fan_dx) * fan_dx) > fan_dx2 then -// if (FAngle + c21)/fan_dx - System.Int((FAngle + c21)/fan_dx) > 0.5 then - if System.Frac((FAngle + c21)/fan_dx) > 0.5 then - a := FAngle - fan_dx2 - else - a := FAngle + fan_dx2; - SinCos(a, sinr, cosr); - r := vars[22] * sqrt(sqr(FTx) + sqr(FTy)); - FPx := FPx + r * cosr; - FPy := FPy + r * sinr; -{$else} -asm - fld qword ptr [ebx + FAngle] - fld st - fadd qword ptr [ebx + c21] - fdiv qword ptr [ebx + fan_dx] -// --Z-- here goes Frac() code from System.pas - FLD ST(0) - SUB ESP,4 - FNSTCW [ESP].Word // save - FNSTCW [ESP+2].Word // scratch - FWAIT - OR [ESP+2].Word, $0F00 // trunc toward zero, full precision - FLDCW [ESP+2].Word - FRNDINT - FWAIT - FLDCW [ESP].Word - ADD ESP,4 - FSUB -// ----- - fadd st, st - fld1 -// fcompp <-- replaced with FCOMIP -// fnstsw ax -// shr ah, 1 -// jnc @else - fcomip st, st(1) - fstp st - //fwait? - ja @else - fsub qword ptr [ebx + fan_dx2] - jmp @skip -@else: - fadd qword ptr [ebx + fan_dx2] -@skip: - fsincos - fld qword ptr [ebx + FTx] - fmul st, st - fld qword ptr [ebx + FTy] - fmul st, st - faddp - fsqrt - mov edx, [ebx + vars] - fmul qword ptr [edx + 22*8] - fmul st(2), st - fmulp - fadd qword ptr [ebx + FPx] - fstp qword ptr [ebx + FPx] - fadd qword ptr [ebx + FPy] - fstp qword ptr [ebx + FPy] - fwait -{$endif} -end; -*) - -/////////////////////////////////////////////////////////////////////////////// -procedure TXForm.Eyefish; -{$ifndef _ASM_} -var - r: double; -begin - r := 2 * vars[11] / (sqrt(sqr(FTx) + sqr(FTy)) + 1); - FPx := FPx + r * FTx; - FPy := FPy + r * FTy; -{$else} -asm - mov edx, [eax + vars] - fld qword ptr [edx + 11*8] - fadd st, st - fld qword ptr [eax + FTy] - fld qword ptr [eax + FTx] - fld st(1) - fmul st, st - fld st(1) - fmul st, st - faddp - fsqrt - fld1 - faddp - fdivp st(3), st - fmul st, st(2) - fadd qword ptr [eax + FPx] - fstp qword ptr [eax + FPx] - fmulp - fadd qword ptr [eax + FPy] - fstp qword ptr [eax + FPy] - fwait -{$endif} -end; - -/////////////////////////////////////////////////////////////////////////////// -procedure TXForm.Bubble; -{$ifndef _ASM_} -var - r: double; -begin - r := (sqr(FTx) + sqr(FTy))/4 + 1; - FPz := FPz + vars[12] * (2 / r - 1); - - r := vars[12] / r; - - FPx := FPx + r * FTx; - FPy := FPy + r * FTy; -{ - t := 4 / (sqr(FTx) + sqr(FTy) + 4); - - FPx := FPx + FTx * t * vars[26]; - FPy := FPy + FTy * t * vars[26]; - FPz := FPz + (2 * t - 1) * vars[26]; -} -{$else} -asm - fld qword ptr [eax + FTy] - fld qword ptr [eax + FTx] - fld st(1) - fmul st, st - fld st(1) - fmul st, st - faddp - fld1 - fadd st, st - fadd st, st - fdivp st(1), st - + fld1 + fadd st, st + fadd st, st + fdivp st(1), st + mov edx, [eax + vars] fld qword ptr [edx + 12*8] @@ -1721,142 +878,55 @@ procedure TXForm.Cylinder; /////////////////////////////////////////////////////////////////////////////// procedure TXForm.Noise; -{$ifndef _ASM_} var - r, sinr, cosr: double; + r, s, sinr, cosr: double; begin - SinCos(random * 2*pi, sinr, cosr); - r := vars[14] * random; + // Randomize here = HACK! Fix me... + Randomize; SinCos(random * 2*pi, sinr, cosr); + s := vars[14]; + r := s * random; FPx := FPx + FTx * r * cosr; FPy := FPy + FTy * r * sinr; -{$else} -asm - mov edx, [ebx + vars] - fld qword ptr [edx + 14*8] - call AsmRandExt - fmulp - call AsmRandExt - fadd st, st - fldpi - fmulp - fsincos - fmul st, st(2) - fmul qword ptr [ebx + FTx] - fadd qword ptr [ebx + FPx] - fstp qword ptr [ebx + FPx] - fmulp - fmul qword ptr [ebx + FTy] - fadd qword ptr [ebx + FPy] - fstp qword ptr [ebx + FPy] - fwait -{$endif} + FPz := FPz + FTz * s; end; /////////////////////////////////////////////////////////////////////////////// procedure TXForm.Blur; -{$ifndef _ASM_} var - r, sina, cosa: double; + r, s, z, sina, cosa: double; begin - SinCos(random * 2*pi, sina, cosa); - r := vars[15] * random; + // Randomize here = HACK! Fix me... + Randomize; SinCos(random * 2*pi, sina, cosa); + s := vars[15]; z := FTz; + r := s * random; FPx := FPx + r * cosa; FPy := FPy + r * sina; -{$else} -asm - mov edx, [ebx + vars] - fld qword ptr [edx + 15*8] - call AsmRandExt - fmulp - call AsmRandExt - fadd st, st - fldpi - fmulp - fsincos - fmul st, st(2) - fadd qword ptr [ebx + FPx] - fstp qword ptr [ebx + FPx] - fmulp - fadd qword ptr [ebx + FPy] - fstp qword ptr [ebx + FPy] - fwait -{$endif} + FPz := FPz + s * z; end; /////////////////////////////////////////////////////////////////////////////// procedure TXForm.Gaussian; -{$ifndef _ASM_} var - r, sina, cosa: double; + r, s, z, sina, cosa: double; begin - SinCos(random * 2*pi, sina, cosa); - r := vars[16] * (gauss_rnd[0] + gauss_rnd[1] + gauss_rnd[2] + gauss_rnd[3] - 2); + // Randomize here = HACK! Fix me... + Randomize; SinCos(random * 2*pi, sina, cosa); + s := vars[16]; z := FTz; + r := s * (gauss_rnd[0] + gauss_rnd[1] + gauss_rnd[2] + gauss_rnd[3] - 2); gauss_rnd[gauss_N] := random; gauss_N := (gauss_N+1) and $3; FPx := FPx + r * cosa; FPy := FPy + r * sina; -{$else} -asm - fld qword ptr [ebx + gauss_rnd] - fadd qword ptr [ebx + gauss_rnd+8] - fadd qword ptr [ebx + gauss_rnd+16] - fadd qword ptr [ebx + gauss_rnd+24] - fld1 - fadd st,st - fsubp st(1),st - mov edx, [ebx + vars] - fmul qword ptr [edx + 16*8] - call AsmRandExt - mov edx, [ebx + gauss_N] - fst qword ptr [ebx + gauss_rnd + edx*8] - inc edx - and edx,$03 - mov [eax + gauss_N], edx - - fadd st, st - fldpi - fmulp - fsincos - fmul st, st(2) - fadd qword ptr [ebx + FPx] - fstp qword ptr [ebx + FPx] - fmulp - fadd qword ptr [ebx + FPy] - fstp qword ptr [ebx + FPy] - fwait -{$endif} + FPz := FPz + s * z; end; /////////////////////////////////////////////////////////////////////////////// procedure TXForm.ZBlur; -{$ifndef _ASM_} begin FPz := FPz + vars[17] * (gauss_rnd[0] + gauss_rnd[1] + gauss_rnd[2] + gauss_rnd[3] - 2); gauss_rnd[gauss_N] := random; gauss_N := (gauss_N+1) and $3; -{$else} -asm - fld qword ptr [ebx + gauss_rnd] - fadd qword ptr [ebx + gauss_rnd+8] - fadd qword ptr [ebx + gauss_rnd+16] - fadd qword ptr [ebx + gauss_rnd+24] - fld1 - fadd st,st - fsubp st(1),st - mov edx, [ebx + vars] - fmul qword ptr [edx + 17*8] - call AsmRandExt - mov edx, [ebx + gauss_N] - fstp qword ptr [ebx + gauss_rnd + edx*8] - inc edx - and edx,$03 - mov [eax + gauss_N], edx - - fadd qword ptr [ebx + FPz] - fstp qword ptr [ebx + FPz] - fwait -{$endif} end; /////////////////////////////////////////////////////////////////////////////// @@ -1864,7 +934,8 @@ procedure TXForm.Blur3D; var r, sina, cosa, sinb, cosb: double; begin - SinCos(random * 2*pi, sina, cosa); + // Randomize here = HACK! Fix me... + Randomize; SinCos(random * 2*pi, sina, cosa); r := vars[18] * (gauss_rnd[0] + gauss_rnd[1] + gauss_rnd[2] + gauss_rnd[3] - 2); gauss_rnd[gauss_N] := random; gauss_N := (gauss_N+1) and $3; @@ -1877,47 +948,17 @@ procedure TXForm.Blur3D; /////////////////////////////////////////////////////////////////////////////// procedure TXForm.PreBlur; -{$ifndef _ASM_} var r, sina, cosa: double; begin - SinCos(random * 2*pi, sina, cosa); + // Randomize here = HACK! Fix me... + Randomize; SinCos(random * 2*pi, sina, cosa); r := vars[19] * (gauss_rnd[0] + gauss_rnd[1] + gauss_rnd[2] + gauss_rnd[3] - 2); gauss_rnd[gauss_N] := random; gauss_N := (gauss_N+1) and $3; FTx := FTx + r * cosa; FTy := FTy + r * sina; -{$else} -asm - fld qword ptr [ebx + gauss_rnd] - fadd qword ptr [ebx + gauss_rnd+8] - fadd qword ptr [ebx + gauss_rnd+16] - fadd qword ptr [ebx + gauss_rnd+24] - fld1 - fadd st,st - fsubp st(1),st - mov edx, [ebx + vars] - fmul qword ptr [edx + 19*8] - call AsmRandExt - mov edx, [ebx + gauss_N] - fst qword ptr [ebx + gauss_rnd + edx*8] - inc edx - and edx,$03 - mov [eax + gauss_N], edx - - fadd st, st - fldpi - fmulp - fsincos - fmul st, st(2) - fadd qword ptr [ebx + FTx] - fstp qword ptr [ebx + FTx] - fmulp - fadd qword ptr [ebx + FTy] - fstp qword ptr [ebx + FTy] - fwait -{$endif} end; @@ -2016,35 +1057,6 @@ procedure TXForm.PostRotateY; FPx := x; end; - -//***************************************************************************// - -(* -procedure TXForm.NextPoint(var px, py, pc: double); -var - i: Integer; -begin - // first compute the color coord -// --Z-- no, first let's optimize this huge expression ;) -// pc := (pc + color) * 0.5 * (1 - symmetry) + symmetry * pc; -// ---> = pc*(1 + symmetry)/2 + color*(1 - symmetry)/2; -// ^^^^^^const^^^^^ ^^^^^^^^^const^^^^^^^^ - pc := pc * colorC1 + colorC2; // heh! :-) - - FTx := c00 * px + c10 * py + c20; - FTy := c01 * px + c11 * py + c21; - - Fpx := 0; - Fpy := 0; - - for i := 0 to FNrFunctions - 1 do - FCalcFunctionList[i]; - - px := FPx; - py := FPy; -end; -*) - /////////////////////////////////////////////////////////////////////////////// procedure TXForm.NextPoint(var CPpoint: TCPpoint); var @@ -2096,83 +1108,6 @@ procedure TXForm.NextPointTo(var CPpoint, ToPoint: TCPpoint); ToPoint.z := FPz; //? end; -{ -/////////////////////////////////////////////////////////////////////////////// -procedure TXForm.NextPoint(var px, py, pz, pc: double); -var - i: Integer; - tpx, tpy: double; -begin - // first compute the color coord - pc := (pc + color) * 0.5 * (1 - symmetry) + symmetry * pc; - - case Orientationtype of - 1: - begin - tpx := px; - tpy := pz; - end; - 2: - begin - tpx := py; - tpy := pz; - end; - else - tpx := px; - tpy := py; - end; - - FTx := c00 * tpx + c10 * tpy + c20; - FTy := c01 * tpx + c11 * tpy + c21; - -(* - if CalculateAngle then begin - if (FTx < -EPS) or (FTx > EPS) or (FTy < -EPS) or (FTy > EPS) then - FAngle := arctan2(FTx, FTy) - else - FAngle := 0.0; - end; - - if CalculateSinCos then begin - Flength := sqrt(sqr(FTx) + sqr(FTy)); - if FLength = 0 then begin - FSinA := 0; - FCosA := 1; - end else begin - FSinA := FTx/FLength; - FCosA := FTy/FLength; - end; - end; - -// if CalculateLength then begin -// FLength := sqrt(FTx * FTx + FTy * FTy); -// end; -*) - - Fpx := 0; - Fpy := 0; - - for i:= 0 to FNrFunctions-1 do - FFunctionList[i]; - - case Orientationtype of - 1: - begin - px := FPx; - pz := FPy; - end; - 2: - begin - py := FPx; - pz := FPy; - end; - else - px := FPx; - py := FPy; - end; -end; -} - /////////////////////////////////////////////////////////////////////////////// procedure TXForm.NextPoint2C(var p: T2CPoint); var @@ -2368,29 +1303,16 @@ procedure TXForm.BuildFunctionlist; //fixed FFunctionList[0] := Linear3D; - FFunctionList[1] := Linear; + FFunctionList[1] := Flatten; FFunctionList[2] := Sinusoidal; FFunctionList[3] := Spherical; FFunctionList[4] := Swirl; FFunctionList[5] := Horseshoe; FFunctionList[6] := Polar; -// FFunctionList[6] := FoldedHandkerchief; -// FFunctionList[7] := Heart; FFunctionList[7] := Disc; FFunctionList[8] := Spiral; FFunctionList[9] := Hyperbolic; FFunctionList[10] := Square; -// FFunctionList[12] := Ex; -// FFunctionList[13] := Julia; -// FFunctionList[14] := Bent; -// FFunctionList[15] := Waves; -// FFunctionList[16] := Fisheye; -// FFunctionList[17] := Popcorn; -// FFunctionList[18] := Exponential; -// FFunctionList[19] := Power; -// FFunctionList[20] := Cosine; -// FFunctionList[21] := Rings; -// FFunctionList[22] := Fan; FFunctionList[11] := Eyefish; FFunctionList[12] := Bubble; FFunctionList[13] := Cylinder; @@ -2401,7 +1323,7 @@ procedure TXForm.BuildFunctionlist; FFunctionList[18] := Blur3D; FFunctionList[19] := PreBlur; - FFunctionList[20] := PreZScale; // vars[20] used in ControlPoint.pas + FFunctionList[20] := PreZScale; FFunctionList[21] := PreZTranslate; FFunctionList[22] := PreRotateX; FFunctionList[23] := PreRotateY; @@ -2412,10 +1334,6 @@ procedure TXForm.BuildFunctionlist; FFunctionList[27] := PostRotateX; FFunctionList[28] := PostRotateY; - - //registered -// for i := 0 to High(FRegVariations) do -// FFunctionList[NRLOCVAR + i] := FRegVariations[i].CalcFunction; end; /////////////////////////////////////////////////////////////////////////////// diff --git a/Source/Forms/About.ddp b/Source/Forms/About.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/About.ddp and /dev/null differ diff --git a/Source/Forms/About.dfm b/Source/Forms/About.dfm index 1b0e33a..c654ee3 100644 --- a/Source/Forms/About.dfm +++ b/Source/Forms/About.dfm @@ -3,7 +3,7 @@ object AboutForm: TAboutForm Top = 320 BorderStyle = bsDialog Caption = 'Apophysis' - ClientHeight = 484 + ClientHeight = 342 ClientWidth = 417 Color = clWindow Font.Charset = DEFAULT_CHARSET @@ -1523,7 +1523,7 @@ object AboutForm: TAboutForm end object Label3: TLabel Left = 16 - Top = 220 + Top = 196 Width = 166 Height = 13 Caption = 'This application was created using:' @@ -1552,21 +1552,21 @@ object AboutForm: TAboutForm end object Label10: TLabel Left = 16 - Top = 380 + Top = 246 Width = 178 Height = 13 Caption = 'flame - cosmic recursive fractal flames' end object Label11: TLabel Left = 16 - Top = 404 + Top = 270 Width = 178 Height = 13 - Caption = 'Copyright '#169' 1992-2007 Scott Draves' + Caption = 'Copyright '#169' 1992-2012 Scott Draves' end object lblFlamecom: TLabel Left = 16 - Top = 420 + Top = 286 Width = 79 Height = 13 Cursor = crHandPoint @@ -1582,7 +1582,7 @@ object AboutForm: TAboutForm end object Bevel1: TBevel Left = 16 - Top = 392 + Top = 258 Width = 385 Height = 9 Shape = bsBottomLine @@ -1603,11 +1603,11 @@ object AboutForm: TAboutForm object Label7: TLabel Left = 140 Top = 148 - Width = 115 + Width = 71 Height = 13 Cursor = crHandPoint Hint = 'http://zueuk.deviantart.com' - Caption = 'Peter "Zueuk" Sdobnov' + Caption = 'Peter Sdobnov' Font.Charset = DEFAULT_CHARSET Font.Color = clBlue Font.Height = -11 @@ -1619,11 +1619,11 @@ object AboutForm: TAboutForm object Label8: TLabel Left = 140 Top = 164 - Width = 96 + Width = 53 Height = 13 Cursor = crHandPoint Hint = 'http://utak3r.pl' - Caption = 'Piotr "utak3r" Borys ' + Caption = 'Piotr Borys ' Font.Charset = DEFAULT_CHARSET Font.Color = clBlue Font.Height = -11 @@ -1633,8 +1633,8 @@ object AboutForm: TAboutForm OnClick = DevelopersClick end object Label9: TLabel - Left = 140 - Top = 180 + Left = 16 + Top = 164 Width = 70 Height = 13 Caption = 'Ronald Hordijk' @@ -1654,7 +1654,7 @@ object AboutForm: TAboutForm end object Label13: TLabel Left = 16 - Top = 244 + Top = 220 Width = 69 Height = 13 Cursor = crHandPoint @@ -1670,7 +1670,7 @@ object AboutForm: TAboutForm end object Label14: TLabel Left = 96 - Top = 244 + Top = 220 Width = 55 Height = 13 Cursor = crHandPoint @@ -1684,22 +1684,6 @@ object AboutForm: TAboutForm ParentFont = False OnClick = DevelopersClick end - object Label15: TLabel - Left = 208 - Top = 244 - Width = 175 - Height = 13 - Cursor = crHandPoint - Hint = 'http://www.torry.net/authorsmore.php?id=6929' - Caption = 'Portable Network Graphics for Delphi' - Font.Charset = DEFAULT_CHARSET - Font.Color = clBlue - Font.Height = -11 - Font.Name = 'MS Sans Serif' - Font.Style = [fsUnderline] - ParentFont = False - OnClick = DevelopersClick - end object Bevel3: TBevel Left = 16 Top = 126 @@ -1710,11 +1694,11 @@ object AboutForm: TAboutForm object Label17: TLabel Left = 264 Top = 148 - Width = 104 + Width = 65 Height = 13 Cursor = crHandPoint - Hint = 'http://xyrus.clan-boa.com' - Caption = 'Georg "Xyrus" Kiehne' + Hint = 'http://xyrus-worx.org' + Caption = 'Georg Kiehne' Font.Charset = DEFAULT_CHARSET Font.Color = clBlue Font.Height = -11 @@ -1728,7 +1712,7 @@ object AboutForm: TAboutForm Top = 116 Width = 110 Height = 13 - Caption = 'Copyright '#169' 2009-2011' + Caption = 'Copyright '#169' 2009-2012' Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 @@ -1736,24 +1720,6 @@ object AboutForm: TAboutForm Font.Style = [] ParentFont = False end - object Label21: TLabel - Left = 16 - Top = 260 - Width = 189 - Height = 13 - Cursor = crHandPoint - Hint = - 'http://www.gumpi.com/Blog/2009/01/20/Alpha1OfWindows7ControlsFor' + - 'Delphi.aspx' - Caption = 'Windows 7 Compatibility pack for Delphi' - Font.Charset = DEFAULT_CHARSET - Font.Color = clBlue - Font.Height = -11 - Font.Name = 'MS Sans Serif' - Font.Style = [fsUnderline] - ParentFont = False - OnClick = DevelopersClick - end object Label16: TLabel Left = 8 Top = 408 @@ -1773,32 +1739,16 @@ object AboutForm: TAboutForm Height = 13 Caption = 'Mark Townsend' end - object Label35: TLabel - Left = 160 - Top = 244 - Width = 42 - Height = 13 - Cursor = crHandPoint - Hint = 'http://www.hicomponents.com/' - Caption = 'ImageEn' - Font.Charset = DEFAULT_CHARSET - Font.Color = clBlue - Font.Height = -11 - Font.Name = 'MS Sans Serif' - Font.Style = [fsUnderline] - ParentFont = False - OnClick = DevelopersClick - end object Bevel2: TBevel Left = 16 - Top = 230 + Top = 206 Width = 385 Height = 11 Shape = bsBottomLine end object Label19: TLabel - Left = 212 - Top = 260 + Left = 160 + Top = 220 Width = 77 Height = 13 Cursor = crHandPoint @@ -1822,51 +1772,14 @@ object AboutForm: TAboutForm end object Label20: TLabel Left = 16 - Top = 450 + Top = 316 Width = 297 Height = 13 AutoSize = False end - object Label22: TLabel - Left = 16 - Top = 308 - Width = 385 - Height = 13 - AutoSize = False - Caption = 'This application is able to use Chaotica' - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'MS Sans Serif' - Font.Style = [] - ParentFont = False - WordWrap = True - end - object Label23: TLabel - Left = 16 - Top = 332 - Width = 385 - Height = 13 - AutoSize = False - Caption = 'Chaotica is Copyright '#169' 2010-2011 Thomas Ludwig.' - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'MS Sans Serif' - Font.Style = [] - ParentFont = False - WordWrap = True - end - object Bevel4: TBevel - Left = 16 - Top = 318 - Width = 385 - Height = 11 - Shape = bsBottomLine - end object btnOK: TButton Left = 320 - Top = 444 + Top = 310 Width = 91 Height = 25 Caption = 'OK' diff --git a/Source/Forms/About.pas b/Source/Forms/About.pas index d23c0cc..207e206 100644 --- a/Source/Forms/About.pas +++ b/Source/Forms/About.pas @@ -44,21 +44,15 @@ TAboutForm = class(TForm) Label12: TLabel; Label13: TLabel; Label14: TLabel; - Label15: TLabel; Bevel3: TBevel; Label17: TLabel; Label18: TLabel; - Label21: TLabel; Label16: TLabel; Label2: TLabel; - Label35: TLabel; Bevel2: TBevel; Label19: TLabel; Label5: TLabel; Label20: TLabel; - Label22: TLabel; - Label23: TLabel; - Bevel4: TBevel; Image1: TImage; procedure btnOKClick(Sender: TObject); procedure FormShow(Sender: TObject); diff --git a/Source/Forms/Adjust.ddp b/Source/Forms/Adjust.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/Adjust.ddp and /dev/null differ diff --git a/Source/Forms/Adjust.dfm b/Source/Forms/Adjust.dfm index d4fb02b..1000592 100644 --- a/Source/Forms/Adjust.dfm +++ b/Source/Forms/Adjust.dfm @@ -171,7 +171,7 @@ object AdjustForm: TAdjustForm Top = 157 Width = 451 Height = 130 - ActivePage = TabSheet3 + ActivePage = TabSheet6 Anchors = [akLeft, akTop, akRight, akBottom] Images = MainForm.Buttons TabOrder = 1 @@ -590,7 +590,7 @@ object AdjustForm: TAdjustForm end object btnMenu: TSpeedButton Left = 4 - Top = 47 + Top = 42 Width = 109 Height = 21 Hint = 'Click for menu' @@ -637,10 +637,11 @@ object AdjustForm: TAdjustForm ParentShowHint = False ShowHint = True OnClick = btnMenuClick + ExplicitTop = 46 end object btnOpen: TSpeedButton Left = 396 - Top = 72 + Top = 67 Width = 23 Height = 21 Hint = 'Open Gradient Browser' @@ -676,10 +677,11 @@ object AdjustForm: TAdjustForm ShowHint = True Transparent = False OnClick = btnOpenClick + ExplicitTop = 71 end object btnSmoothPalette: TSpeedButton Left = 419 - Top = 72 + Top = 67 Width = 23 Height = 21 Hint = 'Smooth Palette' @@ -715,10 +717,11 @@ object AdjustForm: TAdjustForm ShowHint = True Transparent = False OnClick = mnuSmoothPaletteClick + ExplicitTop = 71 end object btnPaste: TSpeedButton Left = 373 - Top = 72 + Top = 67 Width = 23 Height = 21 Hint = 'Paste gradient from clipboard' @@ -754,10 +757,11 @@ object AdjustForm: TAdjustForm ShowHint = True Transparent = False OnClick = btnPasteClick + ExplicitTop = 71 end object btnCopy: TSpeedButton Left = 350 - Top = 72 + Top = 67 Width = 23 Height = 21 Hint = 'Copy gradient to clipboard' @@ -793,10 +797,11 @@ object AdjustForm: TAdjustForm ShowHint = True Transparent = False OnClick = btnCopyClick + ExplicitTop = 71 end object btnColorPreset: TSpeedButton Left = 4 - Top = 73 + Top = 68 Width = 109 Height = 21 Hint = 'Click to choose random preset' @@ -805,12 +810,13 @@ object AdjustForm: TAdjustForm ParentShowHint = False ShowHint = True OnClick = btnColorPresetClick + ExplicitTop = 72 end object GradientPnl: TPanel Left = 0 Top = 0 Width = 443 - Height = 44 + Height = 39 Align = alTop Anchors = [akLeft, akTop, akRight, akBottom] BevelInner = bvRaised @@ -822,7 +828,7 @@ object AdjustForm: TAdjustForm Left = 2 Top = 2 Width = 435 - Height = 36 + Height = 31 Cursor = crHandPoint Align = alClient PopupMenu = GradientPopup @@ -831,11 +837,12 @@ object AdjustForm: TAdjustForm OnMouseDown = GradImageMouseDown OnMouseMove = GradImageMouseMove OnMouseUp = GradImageMouseUp + ExplicitHeight = 36 end end object ScrollBar: TScrollBar Left = 120 - Top = 50 + Top = 45 Width = 179 Height = 15 Anchors = [akLeft, akRight, akBottom] @@ -849,7 +856,7 @@ object AdjustForm: TAdjustForm end object cmbPalette: TComboBox Left = 120 - Top = 73 + Top = 68 Width = 227 Height = 21 BevelInner = bvLowered @@ -958,7 +965,7 @@ object AdjustForm: TAdjustForm end object txtVal: TEdit Left = 306 - Top = 47 + Top = 42 Width = 49 Height = 21 Anchors = [akRight, akBottom] @@ -969,7 +976,7 @@ object AdjustForm: TAdjustForm end object btnReset: TButton Left = 363 - Top = 47 + Top = 42 Width = 79 Height = 21 Anchors = [akRight, akBottom] @@ -995,9 +1002,10 @@ object AdjustForm: TAdjustForm Left = 184 Top = 4 Width = 138 - Height = 88 + Height = 93 Anchors = [akLeft, akTop, akRight, akBottom] Shape = bsFrame + ExplicitHeight = 94 end object Bevel3: TBevel Left = 330 @@ -1194,7 +1202,7 @@ object AdjustForm: TAdjustForm Left = 336 Top = 10 Width = 99 - Height = 45 + Height = 40 Alignment = taLeftJustify Anchors = [akLeft, akTop, akRight, akBottom] Caption = 'Resize Main Window' @@ -1241,7 +1249,6 @@ object AdjustForm: TAdjustForm Width = 75 Height = 21 Anchors = [akLeft, akTop, akRight] - ItemHeight = 13 TabOrder = 6 Text = '384' OnChange = txtHeightChange @@ -1262,7 +1269,6 @@ object AdjustForm: TAdjustForm Width = 75 Height = 21 Anchors = [akLeft, akTop, akRight] - ItemHeight = 13 TabOrder = 5 Text = '512' OnChange = txtWidthChange @@ -1275,138 +1281,132 @@ object AdjustForm: TAdjustForm '1280') end end - object TabSheet5: TTabSheet - Caption = 'Post process' - ImageIndex = 67 - TabVisible = False - object txtERadius: TEdit - Left = 338 - Top = 28 - Width = 63 - Height = 21 + object TabSheet6: TTabSheet + Caption = 'Curves' + ImageIndex = 69 + object CurvesPanel: TPanel + Left = 3 + Top = 1 + Width = 323 + Height = 97 + BevelOuter = bvLowered + Color = clBlack + ParentBackground = False TabOrder = 0 - Text = '9' - OnEnter = txtRadiusEnter - OnExit = txtRadiusExit - OnKeyPress = txtERadiusKeyPress end - object scrollERadius: TScrollBar - Left = 80 - Top = 31 - Width = 249 + object tbWeightLeft: TScrollBar + Left = 111 + Top = 67 + Width = 75 Height = 15 - LargeChange = 10 + Max = 160 PageSize = 0 - Position = 9 + Position = 10 TabOrder = 1 - OnChange = scrollRadiusChange - OnScroll = scrollRadiusScroll + Visible = False + OnChange = WeightChange + OnScroll = WeightScroll end - object pnlERadius: TPanel - Left = 4 - Top = 28 - Width = 69 + object tbWeightRight: TScrollBar + Left = 111 + Top = 83 + Width = 129 + Height = 15 + Max = 160 + PageSize = 0 + Position = 10 + TabOrder = 2 + Visible = False + OnChange = WeightChange + OnScroll = WeightScroll + end + object Panel3: TPanel + Left = 111 + Top = 88 + Width = 121 Height = 21 Cursor = crHandPoint - Hint = 'Click and drag to change value' BevelOuter = bvLowered - Caption = 'Radius' + Caption = ' First CP weight:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ParentFont = False ParentShowHint = False ShowHint = True - TabOrder = 2 - OnDblClick = DragPanelDblClick - OnMouseDown = DragPanelMouseDown - OnMouseMove = DragPanelMouseMove - OnMouseUp = DragPanelMouseUp - end - object txtEMin: TEdit - Left = 338 - Top = 52 - Width = 63 - Height = 21 TabOrder = 3 - Text = '0' - OnEnter = txtMinEnter - OnExit = txtMinExit - OnKeyPress = txtEMinKeyPress - end - object scrollEMin: TScrollBar - Left = 80 - Top = 55 - Width = 249 - Height = 15 - LargeChange = 10 - PageSize = 0 - TabOrder = 4 - OnChange = scrollMinChange - OnScroll = scrollMinScroll + Visible = False end - object pnlEMin: TPanel - Left = 4 - Top = 52 - Width = 69 + object Panel4: TPanel + Left = 119 + Top = 88 + Width = 121 Height = 21 Cursor = crHandPoint - Hint = 'Click and drag to change value' BevelOuter = bvLowered - Caption = 'Minimum' + Caption = ' Second CP weight:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ParentFont = False ParentShowHint = False ShowHint = True - TabOrder = 5 - OnDblClick = DragPanelDblClick - OnMouseDown = DragPanelMouseDown - OnMouseMove = DragPanelMouseMove - OnMouseUp = DragPanelMouseUp - end - object txtECurve: TEdit - Left = 338 - Top = 76 - Width = 63 - Height = 21 - TabOrder = 6 - Text = '0.4' - OnEnter = txtCurveEnter - OnExit = txtCurveExit - OnKeyPress = txtECurveKeyPress - end - object scrollECurve: TScrollBar - Left = 80 - Top = 79 - Width = 249 - Height = 15 - LargeChange = 10 - Min = 10 - PageSize = 0 - Position = 40 - TabOrder = 7 - OnChange = scrollCurveChange - OnScroll = scrollCurveScroll + TabOrder = 4 + Visible = False end - object pnlECurve: TPanel - Left = 4 - Top = 76 - Width = 69 + object Panel5: TPanel + Left = 332 + Top = 3 + Width = 108 Height = 21 Cursor = crHandPoint - Hint = 'Click and drag to change value' - BevelOuter = bvLowered - Caption = 'Curve' + Alignment = taLeftJustify + BevelOuter = bvNone + Caption = ' Selected curve:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ParentFont = False ParentShowHint = False ShowHint = True - TabOrder = 8 - OnDblClick = DragPanelDblClick - OnMouseDown = DragPanelMouseDown - OnMouseMove = DragPanelMouseMove - OnMouseUp = DragPanelMouseUp + TabOrder = 5 end - object cbEnableDE: TCheckBox - Left = 4 - Top = 8 - Width = 405 - Height = 17 - Caption = 'Enable density estimation' - TabOrder = 9 - OnClick = cbEnableDEClick + object cbChannel: TComboBox + Left = 332 + Top = 30 + Width = 107 + Height = 21 + Style = csDropDownList + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ItemIndex = 0 + ParentFont = False + TabOrder = 6 + Text = 'Overall' + OnChange = curveChange + Items.Strings = ( + 'Overall' + 'Red' + 'Green' + 'Blue') + end + object btnResetCurves: TButton + Left = 332 + Top = 75 + Width = 107 + Height = 21 + Caption = 'Reset' + TabOrder = 7 + OnClick = btnResetCurvesClick end end end diff --git a/Source/Forms/Adjust.pas b/Source/Forms/Adjust.pas index 0842cc2..a4db371 100644 --- a/Source/Forms/Adjust.pas +++ b/Source/Forms/Adjust.pas @@ -26,8 +26,8 @@ interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, ExtCtrls, ComCtrls, Buttons, Menus, AppEvnts, - ControlPoint, Cmap, Render, Translation; + StdCtrls, ExtCtrls, ComCtrls, Buttons, Menus, AppEvnts, CurvesControl, + ControlPoint, Cmap, RenderingInterface, Translation; const WM_UPDATE_PARAMS = WM_APP + 5439; @@ -154,20 +154,18 @@ TAdjustForm = class(TForm) Shape1: TShape; txtVal: TEdit; btnReset: TButton; - TabSheet5: TTabSheet; - txtERadius: TEdit; - scrollERadius: TScrollBar; - pnlERadius: TPanel; - txtEMin: TEdit; - scrollEMin: TScrollBar; - pnlEMin: TPanel; - txtECurve: TEdit; - scrollECurve: TScrollBar; - pnlECurve: TPanel; - cbEnableDE: TCheckBox; pnlWidth: TPanel; pnlHeight: TPanel; pnlBackground: TPanel; + TabSheet6: TTabSheet; + CurvesPanel: TPanel; + tbWeightLeft: TScrollBar; + tbWeightRight: TScrollBar; + Panel3: TPanel; + Panel4: TPanel; + Panel5: TPanel; + cbChannel: TComboBox; + btnResetCurves: TButton; procedure FormCreate(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure FormDestroy(Sender: TObject); @@ -316,27 +314,14 @@ TAdjustForm = class(TForm) procedure btnResetClick(Sender: TObject); procedure txtValKeyPress(Sender: TObject; var Key: Char); procedure txtValExit(Sender: TObject); - procedure scrollCurveChange(Sender: TObject); - procedure scrollCurveScroll(Sender: TObject; ScrollCode: TScrollCode; + procedure WeightScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); - procedure scrollMinChange(Sender: TObject); - procedure scrollMinScroll(Sender: TObject; ScrollCode: TScrollCode; - var ScrollPos: Integer); - procedure scrollRadiusChange(Sender: TObject); - procedure scrollRadiusScroll(Sender: TObject; ScrollCode: TScrollCode; - var ScrollPos: Integer); - procedure txtRadiusEnter(Sender: TObject); - procedure txtMinEnter(Sender: TObject); - procedure txtCurveEnter(Sender: TObject); - procedure txtERadiusKeyPress(Sender: TObject; var Key: Char); - procedure txtEMinKeyPress(Sender: TObject; var Key: Char); - procedure txtECurveKeyPress(Sender: TObject; var Key: Char); - procedure txtRadiusExit(Sender: TObject); - procedure txtMinExit(Sender: TObject); - procedure txtCurveExit(Sender: TObject); - procedure cbEnableDEClick(Sender: TObject); + procedure WeightChange(Sender: TObject); + procedure curveChange(Sender: TObject); + procedure btnResetCurvesClick(Sender: TObject); private + CurvesControl: TCurvesControl; Resetting: boolean; Render: TRenderer; bm: TBitmap; @@ -366,6 +351,7 @@ TAdjustForm = class(TForm) oldpos, offset: integer; // for display...? :-\ procedure Apply; + procedure SetCurvesCp(ccp: TControlPoint); function Blur(const radius: integer; const pal: TColorMap): TColorMap; function Frequency(const times: Integer; const pal: TColorMap): TColorMap; procedure SaveMap(FileName: string); @@ -407,16 +393,26 @@ implementation //uses Main, Global, Registry, Mutate, Editor, Save, Browser; uses RndFlame, Main, cmapdata, Math, Browser, Editor, Global, - Save, Mutate, ClipBrd, GradientHlpr, Registry; + Save, Mutate, ClipBrd, GradientHlpr, Registry, Curves; {$R *.DFM} +procedure TAdjustForm.SetCurvesCp(ccp: TControlPoint); +begin + if CurvesControl = nil then Exit; + CurvesControl.SetCp(ccp); +end; + procedure TAdjustForm.UpdateDisplay(PreviewOnly: boolean = false); var pw, ph: integer; r: double; begin cp.copy(MainCp); + SetCurvesCp(MainCp); + + tbWeightLeft.Position := Round(CurvesControl.WeightLeft * 10); + tbWeightRight.Position := Round(CurvesControl.WeightRight * 10); pw := PrevPnl.Width -2; ph := PrevPnl.Height -2; @@ -483,9 +479,6 @@ procedure TAdjustForm.UpdateDisplay(PreviewOnly: boolean = false); txtPersp.Text := Format('%.6g', [cp.cameraPersp]); txtZpos.Text := Format('%.6g', [cp.cameraZpos]); txtDOF.Text := Format('%.6g', [cp.cameraDof]); - - cbEnableDE.Checked := cp.enable_de; - cbEnableDEClick(nil); end; //*** DrawPreview; end; @@ -496,8 +489,12 @@ procedure TAdjustForm.UpdateFlame(bBgOnly: boolean = false); MainForm.StopThread; MainForm.UpdateUndo; MainCp.Copy(cp, true); + SetCurvesCp(cp); + if EditForm.Visible then EditForm.UpdateDisplay; if MutateForm.Visible then MutateForm.UpdateDisplay; + if CurvesForm.Visible then CurvesForm.SetCp(cp); + if bBgOnly then MainForm.tbShowAlphaClick(Self) else @@ -618,6 +615,13 @@ procedure TAdjustForm.FormCreate(Sender: TObject); btnPreset1.Caption := TextByKey('adjustment-tab-size-preset'); btnPreset2.Caption := TextByKey('adjustment-tab-size-preset'); btnPreset3.Caption := TextByKey('adjustment-tab-size-preset'); + TabSheet6.Caption := TextByKey('adjustment-tab-curves-title'); + btnResetCurves.Caption := TextByKey('adjustment-tab-curves-reset'); + Panel5.Caption := TextByKey('adjustment-tab-curves-selected'); + cbChannel.Items[0] := TextByKey('adjustment-tab-curves-overall'); + cbChannel.Items[1] := TextByKey('adjustment-tab-curves-red'); + cbChannel.Items[2] := TextByKey('adjustment-tab-curves-green'); + cbChannel.Items[3] := TextByKey('adjustment-tab-curves-blue'); chkResizeMain.Caption := TextByKey('adjustment-tab-size-resizemain'); mnuInstantPreview.Caption := TextByKey('adjustment-popup-quality-instantpreview'); mnuRandomize.Caption := TextByKey('adjustment-popup-gradient-randomize'); @@ -632,6 +636,18 @@ procedure TAdjustForm.FormCreate(Sender: TObject); mnuSaveAsDefault.Caption := TextByKey('adjustment-popup-gradient-saveasdefault'); btnMenu.Caption := TextByKey('adjustment-tab-gradient-moderotate'); + cbChannel.ItemIndex := 0; + + if not (assigned(curvesControl)) then + begin + CurvesControl := TCurvesControl.Create(self); + CurvesControl.Align := alClient; + CurvesControl.Parent := CurvesPanel; + end; + + tbWeightLeft.Position := Round(CurvesControl.WeightLeft * 10); + tbWeightRight.Position := Round(CurvesControl.WeightRight * 10); + bm := TbitMap.Create; cp := TControlPoint.Create; Render := TRenderer.Create; @@ -651,6 +667,7 @@ procedure TAdjustForm.FormCreate(Sender: TObject); end; Sendmessage(cmbPalette.Handle, CB_SETDROPPEDWIDTH , cmbPalette.width * 2, 0); + SetCurvesCp(MainCp); end; procedure TAdjustForm.FormClose(Sender: TObject; var Action: TCloseAction); @@ -1074,6 +1091,14 @@ procedure TAdjustForm.ColorPanelClick(Sender: TObject); end; end; +procedure TAdjustForm.curveChange(Sender: TObject); +begin + if CurvesControl = nil then Exit; + CurvesControl.ActiveChannel := TCurvesChannel(cbChannel.ItemIndex); + tbWeightLeft.Position := Round(cp.curveWeights[cbChannel.ItemIndex][1] * 10); //Round(CurvesControl.WeightLeft * 10); + tbWeightRight.Position := Round(cp.curveWeights[cbChannel.ItemIndex][2] * 10); //Round(CurvesControl.WeightRight * 10); +end; + procedure TAdjustForm.scrollContrastScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer); begin @@ -1143,9 +1168,11 @@ procedure TAdjustForm.Apply; MainCp.CmapIndex := cmbPalette.ItemIndex; MainCp.cmap := Palette; + SetCurvesCp(MainCp); if EditForm.visible then EditForm.UpdateDisplay; if MutateForm.Visible then MutateForm.UpdateDisplay; + if CurvesForm.Visible then CurvesForm.SetCp(MainCp); if mnuInstantPreview.Checked then DrawPreview; @@ -1885,6 +1912,35 @@ procedure TAdjustForm.ReadPreset(n: integer); SetMainWindowSize; end; +procedure TAdjustForm.WeightChange(Sender: TObject); +begin + CurvesControl.WeightLeft := tbWeightLeft.Position / 10.0; + CurvesControl.WeightRight := tbWeightRight.Position / 10.0; + + cp.curveWeights[cbChannel.ItemIndex][1] := tbWeightLeft.Position / 10.0; + cp.curveWeights[cbChannel.ItemIndex][2] := tbWeightRight.Position / 10.0; + + DrawPreview; +end; + +procedure TAdjustForm.WeightScroll(Sender: TObject; ScrollCode: TScrollCode; + var ScrollPos: Integer); +begin + if ScrollCode <> scEndScroll then Exit; + + MainForm.StopThread; + MainForm.UpdateUndo; + MainCp.Copy(cp, true); + + if EditForm.Visible then EditForm.UpdateDisplay; + if MutateForm.Visible then MutateForm.UpdateDisplay; + if CurvesForm.Visible then CurvesForm.SetCp(cp); + + MainForm.RedrawTimer.enabled := true; +{ if ScrollCode = scEndScroll then + CurvesControl.UpdateFlame; } +end; + procedure TAdjustForm.WritePreset(n: integer); var Registry: TRegistry; @@ -1932,7 +1988,7 @@ function IsNumeric(s: string): boolean; start := 2; for i:=start to length(s) do - if not (s[i] in ['0'..'9']) then + if not (CharInSet(s[i],['0'..'9'])) then begin Result := False; exit; @@ -2153,12 +2209,6 @@ procedure TAdjustForm.DragPanelMouseDown(Sender: TObject; pnlDragValue := cp.cameraDOF else if (Sender = pnlGammaThreshold) then pnlDragValue := cp.gammaThreshRelative - else if (Sender = pnlERadius) then - pnlDragValue := cp.estimator - else if (Sender = pnlECurve) then - pnlDragValue := cp.estimator_curve - else if (Sender = pnlEMin) then - pnlDragValue := cp.estimator_min else enableDrag := false; //assert(false)}; if enableDrag then begin @@ -2270,18 +2320,6 @@ procedure TAdjustForm.DragPanelMouseMove(Sender: TObject; Shift: TShiftState; if v < 0 then v := 0; cp.gammaThreshRelative := v; txtGammaThreshold.Text := FloattoStr(cp.gammaThreshRelative); - end - else if (Sender = pnlECurve) then - begin - scrollECurve.Position := trunc(v * 100); - end - else if (Sender = pnlEMin) then - begin - scrollEMin.Position := trunc(v); - end - else if (Sender = pnlERadius) then - begin - scrollERadius.Position := trunc(v); end else exit; //pEdit^.Text := FloatToStr(v); //pEdit.Refresh; @@ -2382,24 +2420,6 @@ procedure TAdjustForm.DragPanelDblClick(Sender: TObject); cp.gammaThreshRelative := defGammaThreshold; txtGammaThreshold.Text := FloatToStr(defGammaThreshold); end - else if (Sender = pnlECurve) then - begin - cp.estimator_curve := 0.4; - txtEcurve.Text := '0.4'; - scrollECurve.Position := 40; - end - else if (Sender = pnlEMin) then - begin - cp.estimator_min := 0; - txtEmin.Text := '0'; - scrollEmin.Position := 0; - end - else if (Sender = pnlERadius) then - begin - cp.estimator := 9; - txtEradius.Text := '9'; - scrollEradius.Position := 9; - end else exit;//assert(false); UpdateFlame; @@ -2675,161 +2695,36 @@ procedure TAdjustForm.btnResetClick(Sender: TObject); ScrollBar.Position := 0; end; -procedure TAdjustForm.txtValKeyPress(Sender: TObject; var Key: Char); -begin - if Key=#13 then begin - Key := #0; - txtValExit(sender); - end; -end; - -procedure TAdjustForm.TemplateRandomizeGradient; -begin - mnuRandomizeClick(nil); -end; - -procedure TAdjustForm.scrollCurveChange(Sender: TObject); -begin - cp.estimator_curve := scrollECurve.Position / 100; - txtECurve.text := FloatToStr(cp.estimator_curve); - txtECurve.Refresh; - DrawPreview; -end; - -procedure TAdjustForm.scrollCurveScroll(Sender: TObject; - ScrollCode: TScrollCode; var ScrollPos: Integer); -begin - if ScrollCode = scEndScroll then UpdateFlame; -end; - -procedure TAdjustForm.scrollMinChange(Sender: TObject); -begin - cp.estimator_min := scrollEMin.Position; - txtEMin.text := FloatToStr(cp.estimator_min); - txtEMin.Refresh; - DrawPreview; -end; - -procedure TAdjustForm.scrollMinScroll(Sender: TObject; - ScrollCode: TScrollCode; var ScrollPos: Integer); -begin - if ScrollCode = scEndScroll then UpdateFlame; -end; - -procedure TAdjustForm.scrollRadiusChange(Sender: TObject); -begin - cp.estimator := scrollERadius.Position / 18.0; - txtERadius.text := FloatToStr(cp.estimator * 18.0); - txtERadius.Refresh; - DrawPreview; -end; - -procedure TAdjustForm.scrollRadiusScroll(Sender: TObject; - ScrollCode: TScrollCode; var ScrollPos: Integer); +procedure TAdjustForm.btnResetCurvesClick(Sender: TObject); +var i: integer; begin - if ScrollCode = scEndScroll then UpdateFlame; -end; - -procedure TAdjustForm.txtRadiusEnter(Sender: TObject); -begin - EditBoxValue := txtERadius.Text; -end; - -procedure TAdjustForm.txtMinEnter(Sender: TObject); -begin - EditBoxValue := txtEMin.Text; -end; - -procedure TAdjustForm.txtCurveEnter(Sender: TObject); -begin - EditBoxValue := txtECurve.Text; -end; - -procedure TAdjustForm.txtERadiusKeyPress(Sender: TObject; var Key: Char); -begin - if ((key = #13) and (txtGamma.Text <> EditBoxValue)) then - begin - key := #0; - txtRadiusExit(sender); - end; -end; - -procedure TAdjustForm.txtEMinKeyPress(Sender: TObject; var Key: Char); -begin - if ((key = #13) and (txtGamma.Text <> EditBoxValue)) then - begin - key := #0; - txtMinExit(sender); - end; -end; + tbWeightLeft.Position := 10; + tbWeightRight.Position := 10; -procedure TAdjustForm.txtECurveKeyPress(Sender: TObject; var Key: Char); -begin - if ((key = #13) and (txtGamma.Text <> EditBoxValue)) then + with cp do for i := 0 to 3 do begin - key := #0; - txtCurveExit(sender); - end; -end; - -procedure TAdjustForm.txtRadiusExit(Sender: TObject); -var - v: integer; -begin - if (txtERadius.Text <> EditBoxValue) then - try - v := Trunc(StrToFloat(txtERadius.Text) * 100); - if v > scrollERadius.Max then v := scrollERadius.Max; - if v < scrollERadius.Min then v := scrollERadius.Min; - ScrollERadius.Position := v; - UpdateFlame; - except on EConvertError do - txtERadius.Text := FloatToStr(cp.estimator); + curvePoints[i][0].x := 0.00; curvePoints[i][0].y := 0.00; curveWeights[i][0] := 1; + curvePoints[i][1].x := 0.00; curvePoints[i][1].y := 0.00; curveWeights[i][1] := 1; + curvePoints[i][2].x := 1.00; curvePoints[i][2].y := 1.00; curveWeights[i][2] := 1; + curvePoints[i][3].x := 1.00; curvePoints[i][3].y := 1.00; curveWeights[i][3] := 1; end; -end; + MainCp.Copy(cp, true); + SetCurvesCp(MainCp); -procedure TAdjustForm.txtMinExit(Sender: TObject); -var - v: integer; -begin - if (txtEMin.Text <> EditBoxValue) then - try - v := Trunc(StrToFloat(txtEMin.Text) * 100); - if v > scrollEMin.Max then v := scrollEMin.Max; - if v < scrollEMin.Min then v := scrollEMin.Min; - scrollEMin.Position := v; - UpdateFlame; - except on EConvertError do - txtEMin.Text := FloatToStr(cp.estimator_min); - end; + Apply; end; -procedure TAdjustForm.txtCurveExit(Sender: TObject); -var - v: integer; +procedure TAdjustForm.txtValKeyPress(Sender: TObject; var Key: Char); begin - if (txtECurve.Text <> EditBoxValue) then - try - v := Trunc(StrToFloat(txtECurve.Text) * 100); - if v > scrollECurve.Max then v := scrollECurve.Max; - if v < scrollECurve.Min then v := scrollECurve.Min; - scrollECurve.Position := v; - UpdateFlame; - except on EConvertError do - txtECurve.Text := FloatToStr(cp.estimator_curve); + if Key=#13 then begin + Key := #0; + txtValExit(sender); end; end; -procedure TAdjustForm.cbEnableDEClick(Sender: TObject); +procedure TAdjustForm.TemplateRandomizeGradient; begin - cp.enable_de := cbEnableDE.Checked; - scrollERadius.Enabled := cp.enable_de; - scrollEMin.Enabled := cp.enable_de; - scrollECurve.Enabled := cp.enable_de; - txtERadius.Enabled := cp.enable_de; - txtEMin.Enabled := cp.enable_de; - txtECurve.Enabled := cp.enable_de; - if (sender <> nil) then UpdateFlame; + mnuRandomizeClick(nil); end; end. diff --git a/Source/Forms/Browser.ddp b/Source/Forms/Browser.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/Browser.ddp and /dev/null differ diff --git a/Source/Forms/Browser.dfm b/Source/Forms/Browser.dfm index 7845a75..e0c19ea 100644 --- a/Source/Forms/Browser.dfm +++ b/Source/Forms/Browser.dfm @@ -1,8 +1,8 @@ object GradientBrowser: TGradientBrowser Left = 494 Top = 299 - Width = 418 - Height = 282 + Width = 544 + Height = 335 BorderIcons = [biSystemMenu, biMinimize] Caption = 'Gradient Browser' Color = clBtnFace @@ -54,19 +54,20 @@ object GradientBrowser: TGradientBrowser OnClose = FormClose OnCreate = FormCreate OnDestroy = FormDestroy + OnResize = FormResize OnShow = FormShow DesignSize = ( - 410 - 255) + 536 + 306) PixelsPerInch = 96 TextHeight = 13 object btnDefGradient: TSpeedButton - Left = 384 - Top = 226 + Left = 411 + Top = 7 Width = 23 - Height = 22 + Height = 21 Hint = 'Open...' - Anchors = [akRight, akBottom] + Anchors = [akTop, akRight] Flat = True Font.Charset = ANSI_CHARSET Font.Color = clWindowText @@ -106,10 +107,10 @@ object GradientBrowser: TGradientBrowser OnClick = btnDefGradientClick end object ListView: TListView - Left = 0 - Top = 4 - Width = 410 - Height = 214 + Left = 7 + Top = 7 + Width = 398 + Height = 234 Anchors = [akLeft, akTop, akRight, akBottom] Columns = < item @@ -136,7 +137,7 @@ object GradientBrowser: TGradientBrowser object pnlMain: TPanel Left = 0 Top = 0 - Width = 410 + Width = 536 Height = 4 Align = alTop BevelOuter = bvNone @@ -144,8 +145,8 @@ object GradientBrowser: TGradientBrowser end object pnlPreview: TPanel Left = 0 - Top = 225 - Width = 384 + Top = 268 + Width = 487 Height = 25 Anchors = [akLeft, akRight, akBottom] BevelOuter = bvLowered @@ -153,7 +154,7 @@ object GradientBrowser: TGradientBrowser object Image: TImage Left = 1 Top = 1 - Width = 382 + Width = 485 Height = 23 Align = alClient Stretch = True diff --git a/Source/Forms/Browser.pas b/Source/Forms/Browser.pas index 0b6c7f8..59a4e37 100644 --- a/Source/Forms/Browser.pas +++ b/Source/Forms/Browser.pas @@ -28,7 +28,7 @@ interface Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, ComCtrls, ControlPoint, ToolWin, ImgList, StdCtrls, Cmap, Menus, Global, Buttons, Translation, - Render; + RenderingInterface; const PixelCountMax = 32768; @@ -48,6 +48,7 @@ TGradientBrowser = class(TForm) pnlPreview: TPanel; Image: TImage; btnDefGradient: TSpeedButton; + procedure FormResize(Sender: TObject); procedure ListViewChange(Sender: TObject; Item: TListItem; Change: TItemChange); procedure FormCreate(Sender: TObject); @@ -603,5 +604,18 @@ procedure TGradientBrowser.TooltipTimerTimer(Sender: TObject); TooltipTimer.Enabled := false; end; +procedure TGradientBrowser.FormResize(Sender: TObject); +begin + Listview.Width := self.ClientWidth - 4; + btnDefGradient.Left := self.ClientWidth - 2 - btnDefGradient.Width; + ListView.Height := self.ClientHeight - pnlPreview.Height - 6; + btnDefGradient.Top := self.ClientHeight - pnlPreview.Height - 2 + pnlPreview.Height div 2 - btnDefGradient.Height div 2; + ListView.Top := 2; + ListView.Left := 2; + pnlPreview.Top := self.ClientHeight - pnlPreview.Height - 2; + pnlPreview.Left := 2; + pnlPreview.Width := self.ClientWidth - btnDefGradient.Width - 6; +end; + end. diff --git a/Source/Forms/Curves.dfm b/Source/Forms/Curves.dfm new file mode 100644 index 0000000..3b97403 --- /dev/null +++ b/Source/Forms/Curves.dfm @@ -0,0 +1,125 @@ +object CurvesForm: TCurvesForm + Left = 197 + Top = 111 + BorderStyle = bsDialog + Caption = 'Curves' + ClientHeight = 492 + ClientWidth = 489 + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -13 + Font.Name = 'System' + Font.Style = [] + OldCreateOrder = False + OnClose = FormClose + OnCreate = FormCreate + OnShow = FormShow + PixelsPerInch = 96 + TextHeight = 16 + object Label1: TLabel + Left = 8 + Top = 16 + Width = 75 + Height = 13 + Caption = 'Selected curve:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ParentFont = False + end + object CurvesPanel: TPanel + Left = 8 + Top = 68 + Width = 473 + Height = 414 + BevelOuter = bvNone + Color = clBlack + ParentBackground = False + TabOrder = 0 + end + object cbChannel: TComboBox + Left = 8 + Top = 35 + Width = 185 + Height = 21 + Style = csDropDownList + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ItemIndex = 0 + ParentFont = False + TabOrder = 1 + Text = 'Overall' + OnChange = cbChannelChange + Items.Strings = ( + 'Overall' + 'Red' + 'Green' + 'Blue') + end + object tbWeightLeft: TScrollBar + Left = 326 + Top = 8 + Width = 155 + Height = 21 + Max = 160 + PageSize = 0 + Position = 80 + TabOrder = 2 + OnChange = tbWeightChange + OnScroll = tbWeightScroll + end + object tbWeightRight: TScrollBar + Left = 326 + Top = 35 + Width = 155 + Height = 21 + Max = 160 + PageSize = 0 + Position = 80 + TabOrder = 3 + OnChange = tbWeightChange + OnScroll = tbWeightScroll + end + object Panel2: TPanel + Left = 199 + Top = 8 + Width = 121 + Height = 21 + Cursor = crHandPoint + BevelOuter = bvLowered + Caption = ' First CP weight:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ParentFont = False + ParentShowHint = False + ShowHint = True + TabOrder = 4 + end + object Panel1: TPanel + Left = 199 + Top = 35 + Width = 121 + Height = 21 + Cursor = crHandPoint + BevelOuter = bvLowered + Caption = ' Second CP weight:' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + ParentFont = False + ParentShowHint = False + ShowHint = True + TabOrder = 5 + end +end diff --git a/Source/Forms/Curves.pas b/Source/Forms/Curves.pas new file mode 100644 index 0000000..959d238 --- /dev/null +++ b/Source/Forms/Curves.pas @@ -0,0 +1,123 @@ +unit Curves; + +interface + +uses Windows, Classes, Graphics, Forms, Controls, CurvesControl, Vcl.ExtCtrls, + Vcl.StdCtrls, Vcl.ComCtrls, ControlPoint, Registry, Global; + +type + TCurvesForm = class(TForm) + CurvesPanel: TPanel; + cbChannel: TComboBox; + tbWeightLeft: TScrollBar; + tbWeightRight: TScrollBar; + Panel2: TPanel; + Panel1: TPanel; + Label1: TLabel; + procedure FormShow(Sender: TObject); + procedure cbChannelChange(Sender: TObject); + procedure tbWeightChange(Sender: TObject); + procedure tbWeightScroll(Sender: TObject; ScrollCode: TScrollCode; + var ScrollPos: Integer); + procedure FormCreate(Sender: TObject); + procedure FormClose(Sender: TObject; var Action: TCloseAction); + private + { Private declarations } + published + CurvesControl: TCurvesControl; + public + procedure SetCp(cp: TControlPoint); + end; + +var + CurvesForm: TCurvesForm; + +implementation + +uses Main; + +{$R *.DFM} + +procedure TCurvesForm.tbWeightScroll(Sender: TObject; ScrollCode: TScrollCode; + var ScrollPos: Integer); +begin + if ScrollCode = scEndScroll then + CurvesControl.UpdateFlame; +end; + +procedure TCurvesForm.SetCp(cp: TControlPoint); +begin + if CurvesControl = nil then Exit; + CurvesControl.SetCp(cp); +end; + +procedure TCurvesForm.cbChannelChange(Sender: TObject); +begin + if CurvesControl = nil then Exit; + CurvesControl.ActiveChannel := TCurvesChannel(cbChannel.ItemIndex); + tbWeightLeft.Position := Round(CurvesControl.WeightLeft * 10); + tbWeightRight.Position := Round(CurvesControl.WeightRight * 10); +end; + +procedure TCurvesForm.FormClose(Sender: TObject; var Action: TCloseAction); +var + Registry: TRegistry; +begin + { Write position to registry } + Registry := TRegistry.Create; + try + Registry.RootKey := HKEY_CURRENT_USER; + if Registry.OpenKey('\Software\' + APP_NAME + '\Forms\Curves', True) then + begin + Registry.WriteInteger('Top', self.Top); + Registry.WriteInteger('Left', self.Left); + end; + finally + Registry.Free; + end; +// bStop := True; +end; + +procedure TCurvesForm.FormCreate(Sender: TObject); +begin + // +end; + +procedure TCurvesForm.FormShow(Sender: TObject); +var Registry: TRegistry; +begin + if not (assigned(curvesControl)) then + begin + CurvesControl := TCurvesControl.Create(self); + CurvesControl.Align := alClient; + CurvesControl.Parent := CurvesPanel; + end; + + Registry := TRegistry.Create; + try + Registry.RootKey := HKEY_CURRENT_USER; + if Registry.OpenKey('Software\' + APP_NAME + '\Forms\Curves', False) then + begin + if Registry.ValueExists('Left') then + self.Left := Registry.ReadInteger('Left'); + if Registry.ValueExists('Top') then + self.Top := Registry.ReadInteger('Top'); + Registry.CloseKey; + end; + finally + Registry.Free; + end; + + tbWeightLeft.Position := Round(CurvesControl.WeightLeft * 10); + tbWeightRight.Position := Round(CurvesControl.WeightRight * 10); + + SetCp(MainCp); +end; + +procedure TCurvesForm.tbWeightChange(Sender: TObject); +begin + CurvesControl.WeightLeft := tbWeightLeft.Position / 10.0; + CurvesControl.WeightRight := tbWeightRight.Position / 10.0; +end; + +end. diff --git a/Source/Forms/Editor.ddp b/Source/Forms/Editor.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/Editor.ddp and /dev/null differ diff --git a/Source/Forms/Editor.dfm b/Source/Forms/Editor.dfm index 7c3d8ce..b262917 100644 --- a/Source/Forms/Editor.dfm +++ b/Source/Forms/Editor.dfm @@ -1,9 +1,9 @@ object EditForm: TEditForm Left = 509 Top = 87 - Width = 773 - Height = 799 Caption = 'Transform Editor' + ClientHeight = 772 + ClientWidth = 765 Color = clBtnFace Constraints.MinHeight = 400 Constraints.MinWidth = 200 @@ -63,7 +63,7 @@ object EditForm: TEditForm TextHeight = 13 object StatusBar: TStatusBar Left = 0 - Top = 750 + Top = 757 Width = 765 Height = 15 Panels = < @@ -90,14 +90,12 @@ object EditForm: TEditForm object EditorToolBar: TToolBar Left = 1 Top = 1 - Width = 560 + Width = 763 Height = 22 - Align = alLeft + Align = alClient ButtonHeight = 23 Caption = 'EditorToolBar' Color = clBtnFace - EdgeBorders = [] - Flat = True Images = EditorTB ParentColor = False TabOrder = 0 @@ -249,16 +247,8 @@ object EditForm: TEditForm Style = tbsCheck OnClick = tbEditModeClick end - object ToolButton6: TToolButton - Left = 300 - Top = 0 - Width = 8 - Caption = 'ToolButton6' - ImageIndex = 16 - Style = tbsSeparator - end object tbPivotMode: TToolButton - Left = 308 + Left = 300 Top = 0 Hint = 'Toggle world pivot mode' Caption = 'tbPivotMode' @@ -268,17 +258,16 @@ object EditForm: TEditForm Style = tbsCheck OnClick = btnPivotModeClick end - object ToolButton5: TToolButton - Left = 331 + object ToolButton6: TToolButton + Left = 323 Top = 0 Width = 8 - Caption = 'ToolButton5' - ImageIndex = 7 + Caption = 'ToolButton6' + ImageIndex = 16 Style = tbsSeparator - Visible = False end object tbRotate90CCW: TToolButton - Left = 339 + Left = 331 Top = 0 Hint = 'Rotate triangle 90'#176' counter-clockwise' Caption = 'tbRotate90CCW' @@ -288,7 +277,7 @@ object EditForm: TEditForm OnClick = btTrgRotateLeft90Click end object tbRotate90CW: TToolButton - Left = 362 + Left = 354 Top = 0 Hint = 'Rotate triangle 90'#176' clockwise' Caption = 'tbRotate90CW' @@ -298,7 +287,7 @@ object EditForm: TEditForm OnClick = btTrgRotateRight90Click end object tbFlipHorz: TToolButton - Left = 385 + Left = 377 Top = 0 Hint = 'Flip triangle horizontal' Caption = 'Flip Horizontal' @@ -308,7 +297,7 @@ object EditForm: TEditForm OnClick = mnuFlipHorizontalClick end object tbFlipVert: TToolButton - Left = 408 + Left = 400 Top = 0 Hint = 'Flip triangle vertical' Caption = 'Flip Vertical' @@ -318,7 +307,7 @@ object EditForm: TEditForm OnClick = mnuFlipVerticalClick end object ToolButton2: TToolButton - Left = 431 + Left = 423 Top = 0 Width = 8 Caption = 'ToolButton2' @@ -326,7 +315,7 @@ object EditForm: TEditForm Style = tbsSeparator end object tbVarPreview: TToolButton - Left = 439 + Left = 431 Top = 0 Hint = 'Show/hide variation preview' Caption = 'Variation Preview' @@ -337,7 +326,7 @@ object EditForm: TEditForm OnClick = tbVarPreviewClick end object ToolButton3: TToolButton - Left = 462 + Left = 454 Top = 0 Width = 8 Caption = 'ToolButton3' @@ -345,7 +334,7 @@ object EditForm: TEditForm Style = tbsSeparator end object tbPostXswap: TToolButton - Left = 470 + Left = 462 Top = 0 Hint = 'Enable post-triangle editing' Caption = 'tbPostXswap' @@ -356,7 +345,7 @@ object EditForm: TEditForm OnClick = tbPostXswapClick end object tbEnableFinalXform: TToolButton - Left = 493 + Left = 485 Top = 0 Hint = 'Enable final transform' Caption = 'Show Final Xform' @@ -367,7 +356,7 @@ object EditForm: TEditForm OnClick = tbEnableFinalXformClick end object ToolButton8: TToolButton - Left = 516 + Left = 508 Top = 0 Width = 8 Caption = 'ToolButton8' @@ -375,7 +364,7 @@ object EditForm: TEditForm Style = tbsSeparator end object ToolButton7: TToolButton - Left = 524 + Left = 516 Top = 0 Hint = 'Adds a new linked triangle' Caption = 'ToolButton7' @@ -384,20 +373,50 @@ object EditForm: TEditForm ShowHint = True OnClick = mnuLinkPostxformClick end + object ToolButton5: TToolButton + Left = 539 + Top = 0 + Width = 8 + Caption = 'ToolButton5' + ImageIndex = 32 + Style = tbsSeparator + end + object ToolButton12: TToolButton + Left = 547 + Top = 0 + Caption = 'ToolButton12' + ImageIndex = 32 + Visible = False + OnClick = ToolButton12Click + end + object ToolButton13: TToolButton + Left = 570 + Top = 0 + Caption = 'ToolButton13' + ImageIndex = 33 + Visible = False + end + object ToolButton14: TToolButton + Left = 593 + Top = 0 + Caption = 'ToolButton14' + ImageIndex = 34 + Visible = False + end end end object EditPnl: TPanel Left = 0 Top = 24 Width = 765 - Height = 726 + Height = 733 Align = alClient TabOrder = 2 object Splitter1: TSplitter Left = 454 Top = 1 Width = 10 - Height = 724 + Height = 731 Align = alRight AutoSnap = False Beveled = True @@ -408,7 +427,7 @@ object EditForm: TEditForm Left = 1 Top = 1 Width = 453 - Height = 724 + Height = 731 Align = alClient BevelOuter = bvNone Color = clAppWorkSpace @@ -425,7 +444,7 @@ object EditForm: TEditForm Left = 464 Top = 1 Width = 300 - Height = 724 + Height = 731 Align = alRight Alignment = taLeftJustify BevelOuter = bvNone @@ -447,13 +466,13 @@ object EditForm: TEditForm Left = 0 Top = 185 Width = 300 - Height = 539 + Height = 546 Align = alClient TabOrder = 0 OnResize = ControlPanelResize DesignSize = ( 300 - 539) + 546) object PageControl: TPageControl Left = 1 Top = 71 @@ -502,7 +521,6 @@ object EditForm: TEditForm Caption = 'ToolBar1' EdgeInner = esNone EdgeOuter = esNone - Flat = True Images = EditorTB TabOrder = 0 object tbCopyTriangle: TToolButton @@ -937,7 +955,6 @@ object EditForm: TEditForm Width = 65 Height = 21 AutoComplete = False - ItemHeight = 0 ItemIndex = 1 TabOrder = 0 Text = '125' @@ -957,7 +974,6 @@ object EditForm: TEditForm Width = 65 Height = 21 AutoComplete = False - ItemHeight = 0 TabOrder = 1 Text = '15' OnExit = txtValidateValue @@ -979,7 +995,6 @@ object EditForm: TEditForm Width = 65 Height = 21 AutoComplete = False - ItemHeight = 0 ItemIndex = 3 TabOrder = 2 Text = '0.1' @@ -1764,6 +1779,28 @@ object EditForm: TEditForm DesignSize = ( 290 420) + object Label4: TLabel + Left = 2 + Top = 8 + Width = 37 + Height = 13 + Caption = 'Search:' + end + object SpeedButton1: TSpeedButton + Left = 268 + Top = 7 + Width = 17 + Height = 17 + Caption = 'r' + Flat = True + Font.Charset = SYMBOL_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Marlett' + Font.Style = [] + ParentFont = False + OnClick = btnResetSearchClick + end object btnLoadVVAR: TButton Left = 0 Top = 392 @@ -1778,10 +1815,9 @@ object EditForm: TEditForm end object VEVars: TValueListEditor Left = 0 - Top = 0 + Top = 32 Width = 290 - Height = 367 - Align = alTop + Height = 335 Anchors = [akLeft, akTop, akRight, akBottom] DefaultColWidth = 90 ScrollBars = ssVertical @@ -1821,6 +1857,15 @@ object EditForm: TEditForm TabOrder = 2 OnClick = bClearClick end + object txtSearchBox: TEdit + Left = 48 + Top = 5 + Width = 217 + Height = 21 + Anchors = [akLeft, akTop, akRight] + TabOrder = 4 + OnChange = txtSearchBoxChange + end end object TabSheet4: TTabSheet Caption = 'Variables' @@ -2028,8 +2073,8 @@ object EditForm: TEditForm end object EditPopup: TPopupMenu Images = EditorTB - Left = 352 - Top = 40 + Left = 400 + Top = 112 object mnuUndo: TMenuItem Caption = 'Undo' Enabled = False @@ -2161,7 +2206,7 @@ object EditForm: TEditForm Left = 313 Top = 40 Bitmap = { - 494C010120002200040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 + 494C010120003000180010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 0000000000003600000028000000400000009000000001002000000000000090 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 @@ -3359,8 +3404,8 @@ object EditForm: TEditForm object TrianglePopup: TPopupMenu AutoPopup = False Images = EditorTB - Left = 353 - Top = 73 + Left = 329 + Top = 129 object mnuReset: TMenuItem Caption = 'Reset triangle' Hint = 'Reset triangle' diff --git a/Source/Forms/Editor.pas b/Source/Forms/Editor.pas index 777e609..3832e4e 100644 --- a/Source/Forms/Editor.pas +++ b/Source/Forms/Editor.pas @@ -32,9 +32,9 @@ interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, ComCtrls, Math, Menus, ToolWin, Registry, - Grids, ValEdit, Buttons, ImgList, Types, + Grids, ValEdit, Buttons, ImgList, Types, StrUtils , Curves, ControlPoint, XForm, cmap, CustomDrawControl, - Render, Translation, RenderThread; + RenderingInterface, Translation, RenderThread; type TEditForm = class(TForm) @@ -64,7 +64,6 @@ TEditForm = class(TForm) ToolButton1: TToolButton; tbUndo: TToolButton; tbRedo: TToolButton; - ToolButton5: TToolButton; tbScale: TToolButton; tbFlipHorz: TToolButton; tbFlipVert: TToolButton; @@ -240,6 +239,17 @@ TEditForm = class(TForm) mnuEHighQuality: TMenuItem; mnuEMediumQuality: TMenuItem; mnuELowQuality: TMenuItem; + Label4: TLabel; + txtSearchBox: TEdit; + ToolButton5: TToolButton; + ToolButton12: TToolButton; + ToolButton13: TToolButton; + ToolButton14: TToolButton; + SpeedButton1: TSpeedButton; + procedure ToolButton12Click(Sender: TObject); + procedure btnResetSearchClick(Sender: TObject); + procedure txtSearchBoxKeyPress(Sender: TObject; var Key: Char); + procedure txtSearchBoxChange(Sender: TObject); procedure FormActivate(Sender: TObject); procedure ScrollBox1Resize(Sender: TObject); procedure ScrollBox2Resize(Sender: TObject); @@ -479,6 +489,8 @@ TEditForm = class(TForm) pnlDragPos, pnlDragOld: integer; pnlDragValue: double; + LastFocus: TEdit; + procedure UpdateFlameX; procedure UpdateFlame(DrawMain: boolean); procedure UpdateWidgets; @@ -495,6 +507,7 @@ TEditForm = class(TForm) procedure TriangleViewPaint(Sender: TObject); procedure AutoZoom; + procedure KeyInput(str: string); public cp: TControlPoint; Render: TRenderer; @@ -523,7 +536,7 @@ TEditForm = class(TForm) $0000ff, $00ffff, $00ff00, $ffff00, $ff0000, $ff00ff, $007fff, $7f00ff, $55ffff, $ccffcc, $ffffaa, $ff7f7f, $ffaaff, $55ccff );} TrgColors: array[-1..13] of TColor = (clGray, - $0000ff, $00cccc, $00cc00, $cccc00, $cc0000, $cc00cc, $0080cc, + $0000ff, $00cccc, $00cc00, $cccc00, $ff4040, $cc00cc, $0080cc, $4f0080, $228080, $608060, $808050, $804f4f, $805080, $226080 ); var @@ -815,7 +828,8 @@ procedure TEditForm.ShowSelectedInfo; begin updating := true; - if (SelectedTriangle > LastTriangle) then SelectedTriangle := LastTriangle; + if (SelectedTriangle > LastTriangle) then + SelectedTriangle := LastTriangle; for i:=0 to Transforms -1 do begin if (i >= Transforms) then begin if (cbTransforms.Items.Count > Transforms) then cbTransforms.Items[i] := TextByKey('editor-common-finalxformlistitem') @@ -994,7 +1008,9 @@ procedure TEditForm.ShowSelectedInfo; vleChaos.Cells[1, i] := 'n/a'; txtName.Text := TransformName; - if (SelectedTriangle >= Transforms) then txtName.Text := 'n/a'; + if (SelectedTriangle >= Transforms) then begin + txtName.Text := 'n/a'; + end; end; if PivotMode = pivotLocal then begin @@ -1093,6 +1109,7 @@ procedure TEditForm.UpdateFlame(DrawMain: boolean); end; if AdjustForm.Visible then AdjustForm.UpdateDisplay; if MutateForm.Visible then MutateForm.UpdateDisplay; + if CurvesForm.Visible then CurvesForm.SetCp(MainCp); MainForm.RedrawTimer.enabled := true; end; @@ -1841,10 +1858,14 @@ procedure TEditForm.TriangleViewPaint(Sender: TObject); procedure TEditForm.FormCreate(Sender: TObject); var i: integer; + vn: string; begin mnuELowQuality.Caption := TextByKey('common-lowquality'); mnuEMediumQuality.Caption := TextByKey('common-mediumquality'); mnuEHighQuality.Caption := TextByKey('common-highquality'); + mnuLowQuality.Caption := TextByKey('common-lowquality'); + mnuMediumQuality.Caption := TextByKey('common-mediumquality'); + mnuHighQuality.Caption := TextByKey('common-highquality'); ToolButton9.Caption := TextByKey('common-copy'); ToolButton9.Hint := TextByKey('common-copy'); tbCopyTriangle.Hint := TextByKey('common-copy'); @@ -2016,10 +2037,12 @@ procedure TEditForm.FormCreate(Sender: TObject); TriangleView.OnMouseLeave := TriangleViewmouseLeave; for i:= 0 to NRVAR - 1 do begin - VEVars.InsertRow(Varnames(i), '0', True); + vn := Varnames(i); + VEVars.InsertRow(vn, '0', True); end; for i:= 0 to GetNrVariableNames - 1 do begin - vleVariables.InsertRow(GetVariableNameAt(i), '0', True); + vn := GetVariableNameAt(i); + vleVariables.InsertRow(vn, '0', True); end; vleChaos.InsertRow(Format(TextByKey('editor-common-toprefix'), [1]), '1', true); @@ -2894,6 +2917,8 @@ procedure TEditForm.CornerEditExit(Sender: TObject); MainForm.UpdateUndo; UpdateFlame(True); end; + + self.LastFocus := TEdit(sender); end; procedure TEditForm.CornerEditKeyPress(Sender: TObject; var Key: Char); @@ -3027,6 +3052,7 @@ procedure TEditForm.txtPExit(Sender: TObject); //ReadjustWeights(cp); UpdateFlame(True); end; + self.LastFocus := TEdit(sender); end; { **************************************************************************** } @@ -3075,31 +3101,34 @@ procedure TEditForm.mnuRedoClick(Sender: TObject); procedure TEditForm.mnuLowQualityClick(Sender: TObject); begin + mnuLowQuality.Checked := True; mnuELowQuality.Checked := True; //tbLowQ.Down := true; PreviewDensity := prevLowQuality; EditPrevQual := 0; - //DrawPreview; + DrawPreview; TriangleViewPaint(TriangleView); end; procedure TEditForm.mnuHighQualityClick(Sender: TObject); begin + mnuHighQuality.Checked := True; mnuEHighQuality.Checked := True; //tbHiQ.Down := true; PreviewDensity := prevHighQuality; EditPrevQual := 2; - //DrawPreview; + DrawPreview; TriangleViewPaint(TriangleView); end; procedure TEditForm.mnuMediumQualityClick(Sender: TObject); begin + mnuMediumQuality.Checked := True; mnuEMediumQuality.Checked := True; //tbMedQ.Down := true; PreviewDensity := prevMediumQuality; EditPrevQual := 1; - //DrawPreview; + DrawPreview; TriangleViewPaint(TriangleView); end; @@ -3190,6 +3219,13 @@ procedure TEditForm.cbTransformsChange(Sender: TObject); n: integer; begin n := cbTransforms.ItemIndex; + // We got a bug in the ComboBox-control :( + {if (EnableFinalXForm or cp.HasFinalXForm) and (SelectedTriangle = LastTriangle) then + begin + n := cbTransforms.Items.Count - 1; + end;} + // + if (n <> SelectedTriangle) and (n >= 0) and (n <= LastTriangle) then begin SelectedTriangle := n; @@ -3309,6 +3345,8 @@ procedure TEditForm.CoefValidate(Sender: TObject); ShowSelectedInfo; UpdateFlame(true); + + self.LastFocus := TEdit(sender); end; procedure TEditForm.scrlXFormColorScroll(Sender: TObject; @@ -4290,9 +4328,11 @@ procedure TEditForm.EditKeyPress(Sender: TObject; var Key: Char); end; if (key='"') then key := #0; // we dont want that in "name" box -> XML mess! exit; + end else if txtSearchBox.Focused then begin + exit; end; // kill alphanumeric keys generally - if key_handled or (key in ['A'..'z']) then key := #0; // hmmm... + if key_handled or (CharInSet(key,['A'..'z'])) then key := #0; // hmmm... end; procedure TEditForm.splitterMoved(Sender: TObject); @@ -4808,6 +4848,8 @@ procedure TEditForm.PostCoefValidate(Sender: TObject); ShowSelectedInfo; UpdateFlame(true); + + self.LastFocus := TEdit(sender); end; procedure TEditForm.btnResetCoefsClick(Sender: TObject); @@ -4899,6 +4941,8 @@ procedure TEditForm.PivotValidate(Sender: TObject); TriangleView.Invalidate; ShowSelectedInfo; + + self.LastFocus := TEdit(sender); end; procedure TEditForm.PivotKeyPress(Sender: TObject; var Key: Char); @@ -5678,13 +5722,26 @@ procedure TEditForm.mnuChaosRebuildClick(Sender: TObject); procedure TEditForm.chkCollapseVariationsClick(Sender: TObject); var i:integer; + s:string; begin + //txtSearchBox.Text := ''; + s:=Trim(txtSearchBox.Text); for i:= 1 to VEVars.RowCount - 1 do begin - if ((Assigned(cp)) and (VEVars.Cells[1,i]='0')) then - if chkCollapseVariations.Checked then VEVars.RowHeights[i] := -1 - else VEVars.RowHeights[i] := VEVars.DefaultRowHeight - else - VEVars.RowHeights[i] := VEVars.DefaultRowHeight; + if (Length(s) = 0) then begin + if ((Assigned(cp)) and (VEVars.Cells[1,i]='0')) then + if chkCollapseVariations.Checked then VEVars.RowHeights[i] := -1 + else VEVars.RowHeights[i] := VEVars.DefaultRowHeight + else VEVars.RowHeights[i] := VEVars.DefaultRowHeight; + end else begin + if (Length(s) > Length(VEVars.Cells[0, i])) then + VEVars.RowHeights[i] := -1 + else if Pos(s, VEVars.Cells[0, i]) > 0 then begin + if ((Assigned(cp)) and (VEVars.Cells[1,i]='0')) then + if chkCollapseVariations.Checked then VEVars.RowHeights[i] := -1 + else VEVars.RowHeights[i] := VEVars.DefaultRowHeight + else VEVars.RowHeights[i] := VEVars.DefaultRowHeight; + end else VEVars.RowHeights[i] := -1; + end; end; end; @@ -5856,4 +5913,65 @@ procedure TEditForm.FormActivate(Sender: TObject); end; end; +procedure TEditForm.txtSearchBoxChange(Sender: TObject); +var + i:integer; + s:string; +begin + s:=Trim(txtSearchBox.Text); + for i:= 1 to VEVars.RowCount - 1 do begin + if (Length(s) = 0) then begin + if ((Assigned(cp)) and (VEVars.Cells[1,i]='0')) then + if chkCollapseVariations.Checked then VEVars.RowHeights[i] := -1 + else VEVars.RowHeights[i] := VEVars.DefaultRowHeight + else VEVars.RowHeights[i] := VEVars.DefaultRowHeight; + end else begin + if (Length(s) > Length(VEVars.Cells[0, i])) then + VEVars.RowHeights[i] := -1 + else if Pos(s, VEVars.Cells[0, i]) > 0 then begin + if ((Assigned(cp)) and (VEVars.Cells[1,i]='0')) then + if chkCollapseVariations.Checked then VEVars.RowHeights[i] := -1 + else VEVars.RowHeights[i] := VEVars.DefaultRowHeight + else VEVars.RowHeights[i] := VEVars.DefaultRowHeight; + end else VEVars.RowHeights[i] := -1; + end; + end; +end; + +procedure TEditForm.txtSearchBoxKeyPress(Sender: TObject; var Key: Char); +begin + txtSearchBoxChange(Sender); +end; + +procedure TEditForm.btnResetSearchClick(Sender: TObject); +begin + txtSearchBox.Text := ''; +end; + +procedure TEditForm.KeyInput(str:string); +var + Inp: TInput; + I: Integer; +begin + for I := 1 to Length(Str) do + begin + Inp.Itype := INPUT_KEYBOARD; + Inp.ki.wVk := Ord(UpCase(Str[i])); + Inp.ki.dwFlags := 0; + SendInput(1, Inp, SizeOf(Inp)); + Inp.Itype := INPUT_KEYBOARD; + Inp.ki.wVk := Ord(UpCase(Str[i])); + Inp.ki.dwFlags := KEYEVENTF_KEYUP; + SendInput(1, Inp, SizeOf(Inp)); + Application.ProcessMessages; + Sleep(1); + end; +end; + +procedure TEditForm.ToolButton12Click(Sender: TObject); +begin + KeyInput('3.141592'); +end; + end. + diff --git a/Source/Forms/FormExport.ddp b/Source/Forms/FormExport.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/FormExport.ddp and /dev/null differ diff --git a/Source/Forms/FormExportC.ddp b/Source/Forms/FormExportC.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/FormExportC.ddp and /dev/null differ diff --git a/Source/Forms/FormFavorites.ddp b/Source/Forms/FormFavorites.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/FormFavorites.ddp and /dev/null differ diff --git a/Source/Forms/FormRender.ddp b/Source/Forms/FormRender.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/FormRender.ddp and /dev/null differ diff --git a/Source/Forms/FormRender.dfm b/Source/Forms/FormRender.dfm index f0ddc37..19773e9 100644 --- a/Source/Forms/FormRender.dfm +++ b/Source/Forms/FormRender.dfm @@ -4,7 +4,7 @@ object RenderForm: TRenderForm BorderIcons = [biSystemMenu, biMinimize] BorderStyle = bsSingle Caption = 'Render to Disk' - ClientHeight = 496 + ClientHeight = 469 ClientWidth = 497 Color = clBtnFace Font.Charset = DEFAULT_CHARSET @@ -20,63 +20,59 @@ object RenderForm: TRenderForm OnShow = FormShow DesignSize = ( 497 - 496) + 469) PixelsPerInch = 96 TextHeight = 13 - object ProgressBar: TProgressBar - Left = 488 - Top = 475 - Width = 9 - Height = 13 - TabOrder = 0 - Visible = False - end object btnRender: TButton Left = 256 - Top = 439 + Top = 420 Width = 75 Height = 25 Anchors = [akRight, akBottom] Caption = 'Start' Default = True - TabOrder = 1 + TabOrder = 0 OnClick = btnRenderClick end object btnCancel: TButton Left = 416 - Top = 439 + Top = 420 Width = 75 Height = 25 Anchors = [akRight, akBottom] Caption = 'Close' - TabOrder = 2 + TabOrder = 1 OnClick = btnCancelClick end object btnPause: TButton Left = 336 - Top = 439 + Top = 420 Width = 75 Height = 25 Anchors = [akRight, akBottom] Caption = 'Pause' - TabOrder = 3 + TabOrder = 2 OnClick = btnPauseClick end object PageCtrl: TPageControl Left = 8 Top = 8 Width = 481 - Height = 393 + Height = 373 ActivePage = TabSettings Anchors = [akLeft, akTop, akRight, akBottom] Images = MainForm.Buttons - TabOrder = 4 + TabOrder = 3 object TabSettings: TTabSheet Caption = 'Settings' ImageIndex = 18 + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 DesignSize = ( 473 - 364) + 344) object btnBrowse: TSpeedButton Left = 416 Top = 11 @@ -215,14 +211,13 @@ object RenderForm: TRenderForm Width = 351 Height = 21 Style = csDropDownList - ItemHeight = 13 TabOrder = 0 OnChange = cmbPresetChange end end object GroupBox2: TGroupBox Left = 8 - Top = 66 + Top = 42 Width = 233 Height = 95 Anchors = [akLeft, akTop, akRight] @@ -293,7 +288,6 @@ object RenderForm: TRenderForm Anchors = [akLeft, akTop, akRight] BiDiMode = bdLeftToRight Enabled = False - ItemHeight = 13 ParentBiDiMode = False TabOrder = 2 OnChange = txtHeightChange @@ -317,7 +311,6 @@ object RenderForm: TRenderForm Anchors = [akLeft, akTop, akRight] BiDiMode = bdLeftToRight Enabled = False - ItemHeight = 13 ParentBiDiMode = False TabOrder = 1 OnChange = txtWidthChange @@ -336,7 +329,7 @@ object RenderForm: TRenderForm end object GroupBox3: TGroupBox Left = 248 - Top = 66 + Top = 42 Width = 218 Height = 95 Anchors = [akTop, akRight] @@ -394,7 +387,6 @@ object RenderForm: TRenderForm Height = 21 AutoComplete = False Anchors = [akLeft, akTop, akRight] - ItemHeight = 13 TabOrder = 0 OnChange = txtDensityChange OnCloseUp = txtDensityChange @@ -434,15 +426,15 @@ object RenderForm: TRenderForm end object GroupBox4: TGroupBox Left = 8 - Top = 166 + Top = 142 Width = 458 - Height = 83 + Height = 99 Anchors = [akLeft, akTop, akRight] Caption = 'Resource usage' TabOrder = 3 DesignSize = ( 458 - 83) + 99) object lblApproxMem: TLabel Left = 439 Top = 100 @@ -491,10 +483,10 @@ object RenderForm: TRenderForm Visible = False end object lblMemory: TLabel - Left = 8 - Top = 16 + Left = 11 + Top = 18 Width = 442 - Height = 33 + Height = 24 Anchors = [akLeft, akTop, akRight] AutoSize = False Caption = @@ -509,6 +501,22 @@ object RenderForm: TRenderForm Layout = tlCenter WordWrap = True end + object lblCPUCores: TLabel + Left = 11 + Top = 43 + Width = 442 + Height = 14 + Anchors = [akLeft, akTop, akRight] + AutoSize = False + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + ParentFont = False + Layout = tlCenter + WordWrap = True + end object chkLimitMem: TCheckBox Left = 444 Top = 134 @@ -518,35 +526,23 @@ object RenderForm: TRenderForm TabOrder = 0 Visible = False end - object PBMem: TdwProgressBar - Left = 232 - Top = 54 - Width = 218 - Height = 17 - Anchors = [akLeft, akTop, akRight] - Smooth = True - TabOrder = 2 - DoubleBuffered = False - MarqueeInterval = 50 - end object pnlLimit: TPanel Left = 8 - Top = 52 + Top = 68 Width = 121 Height = 21 Cursor = crArrow BevelOuter = bvLowered Caption = 'Memory limit' - TabOrder = 3 + TabOrder = 2 end object cbMaxMemory: TComboBox Left = 128 - Top = 52 + Top = 68 Width = 97 Height = 21 Style = csDropDownList BiDiMode = bdLeftToRight - ItemHeight = 13 ItemIndex = 0 ParentBiDiMode = False TabOrder = 1 @@ -562,17 +558,24 @@ object RenderForm: TRenderForm '1024' '1536') end + object PBMem: TProgressBar + Left = 232 + Top = 68 + Width = 217 + Height = 21 + TabOrder = 3 + end end object GroupBox1: TGroupBox Left = 8 - Top = 256 + Top = 253 Width = 217 - Height = 97 + Height = 81 Caption = 'Output options' TabOrder = 5 DesignSize = ( 217 - 97) + 81) object chkSave: TCheckBox Left = 8 Top = 24 @@ -584,39 +587,28 @@ object RenderForm: TRenderForm State = cbChecked TabOrder = 0 end - object cbEXIF: TCheckBox + object chkSaveIncompleteRenders: TCheckBox Left = 8 Top = 48 Width = 201 Height = 17 Anchors = [akLeft, akTop, akRight] - Caption = 'Write EXIF-Header (JPEG only)' - Enabled = False + Caption = 'Save incomplete renders' TabOrder = 1 - OnClick = cbEXIFClick - end - object cbParEXIF: TCheckBox - Left = 8 - Top = 72 - Width = 201 - Height = 17 - Anchors = [akLeft, akTop, akRight] - Caption = 'Include parameters in EXIF-Header' - Enabled = False - TabOrder = 2 + OnClick = chkSaveIncompleteRendersClick end end object GroupBox6: TGroupBox Left = 232 - Top = 256 + Top = 253 Width = 234 - Height = 97 + Height = 81 Anchors = [akLeft, akTop, akRight] Caption = 'Completion options' TabOrder = 6 DesignSize = ( 234 - 97) + 81) object chkPostProcess: TCheckBox Left = 8 Top = 24 @@ -635,16 +627,6 @@ object RenderForm: TRenderForm Caption = 'Shut down computer when complete' TabOrder = 1 end - object chkSaveIncompleteRenders: TCheckBox - Left = 8 - Top = 72 - Width = 217 - Height = 17 - Anchors = [akLeft, akTop, akRight] - Caption = 'Save incomplete renders' - TabOrder = 2 - OnClick = chkSaveIncompleteRendersClick - end end object pnlTarget: TPanel Left = 8 @@ -654,17 +636,7 @@ object RenderForm: TRenderForm Cursor = crArrow BevelOuter = bvLowered Caption = 'Destination' - TabOrder = 8 - end - object pnlAuthor: TPanel - Left = 8 - Top = 36 - Width = 121 - Height = 21 - Cursor = crArrow - BevelOuter = bvLowered - Caption = 'Author (EXIF)' - TabOrder = 9 + TabOrder = 7 end object txtFilename: TEdit Left = 128 @@ -675,23 +647,32 @@ object RenderForm: TRenderForm TabOrder = 4 OnChange = txtFilenameChange end - object txtAuthor: TEdit - Left = 128 - Top = 36 - Width = 336 - Height = 21 + object chkBinary: TCheckBox + Left = 8 + Top = 349 + Width = 457 + Height = 17 Anchors = [akLeft, akTop, akRight] - TabOrder = 7 + Caption = + 'Write raw data (WARNING: this is experimental and slows down the' + + ' rendering!!!)' + Enabled = False + TabOrder = 8 + Visible = False end end object TabOutput: TTabSheet Caption = 'Output' ImageIndex = 38 + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 object Output: TMemo Left = 0 Top = 0 Width = 473 - Height = 378 + Height = 344 Align = alClient BorderStyle = bsNone Color = clBtnFace @@ -707,20 +688,9 @@ object RenderForm: TRenderForm end end end - object ProgressBar2: TdwProgressBar - Left = 8 - Top = 413 - Width = 481 - Height = 17 - Anchors = [akLeft, akRight, akBottom] - Smooth = True - TabOrder = 6 - DoubleBuffered = False - MarqueeInterval = 50 - end object StatusBar: TStatusBar Left = 0 - Top = 477 + Top = 450 Width = 497 Height = 19 Panels = < @@ -734,83 +704,38 @@ object RenderForm: TRenderForm Width = 50 end> end - object chkThreadPriority: TCheckBox - Left = 488 - Top = 361 - Width = 161 - Height = 17 - Anchors = [akLeft, akBottom] - Caption = 'Render at low priority' - Enabled = False - TabOrder = 7 - Visible = False - OnClick = chkThreadPriorityClick - end - object TEST_btnSnapshot: TButton + object btnDonate: TButton Left = 8 - Top = 440 - Width = 113 + Top = 420 + Width = 73 Height = 25 - Caption = 'Snap!' - TabOrder = 8 - Visible = False - OnClick = TEST_btnSnapshotClick - end - object cbBitsPerSample: TComboBox - Left = 88 - Top = 452 - Width = 97 - Height = 21 - Style = csDropDownList - Enabled = False - ItemHeight = 13 - TabOrder = 9 - Visible = False - OnSelect = cbBitsPerSampleSelect - Items.Strings = ( - '32-bit integer' - '32-bit floating-point' - '48-bit integer') + Anchors = [akLeft, akBottom] + Caption = 'Donate' + TabOrder = 6 + OnClick = btnDonateClick end - object pnlBufferDepth: TPanel + object btnSaveLog: TButton Left = 88 - Top = 452 - Width = 121 - Height = 21 - Cursor = crArrow - BevelOuter = bvLowered - Caption = 'Buffer depth' + Top = 420 + Width = 73 + Height = 25 + Anchors = [akLeft, akBottom] + Caption = 'Save log' Enabled = False - Font.Charset = DEFAULT_CHARSET - Font.Color = clGrayText - Font.Height = -11 - Font.Name = 'MS Sans Serif' - Font.Style = [] - ParentFont = False - TabOrder = 10 + TabOrder = 5 Visible = False + OnClick = btnSaveLogClick end - object TEST_btnUseSnapshot: TButton - Left = 128 - Top = 440 - Width = 113 + object ProgressBar2: TProgressBar + Left = 8 + Top = 388 + Width = 481 Height = 25 - Caption = 'Scan!' - TabOrder = 11 - Visible = False - OnClick = TEST_btnUseSnapshotClick + Anchors = [akLeft, akRight, akBottom] + TabOrder = 7 end object SaveDialog: TSaveDialog - Left = 184 - Top = 448 - end - object en: TImageEnIO - PreviewFont.Charset = DEFAULT_CHARSET - PreviewFont.Color = clWindowText - PreviewFont.Height = -11 - PreviewFont.Name = 'MS Sans Serif' - PreviewFont.Style = [] - Left = 216 - Top = 448 + Left = 168 + Top = 464 end end diff --git a/Source/Forms/FormRender.pas b/Source/Forms/FormRender.pas index ee29319..26b5c58 100644 --- a/Source/Forms/FormRender.pas +++ b/Source/Forms/FormRender.pas @@ -26,13 +26,12 @@ interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, ComCtrls, Math, Buttons, Registry, ExtCtrls, MMSystem, - ControlPoint, RenderThread, cmap, RenderTypes, dwTaskbarComponents, - dwProgressBar, ShellAPI, imageenio, Translation; + StdCtrls, ComCtrls, Math, Buttons, Registry, ExtCtrls, MMSystem, Windows7, + ControlPoint, RenderThread, cmap, RenderingCommon, RenderingInterface, + ShellAPI, Translation, ActiveX, ComObj; type TRenderForm = class(TForm) - ProgressBar: TProgressBar; btnRender: TButton; btnCancel: TButton; SaveDialog: TSaveDialog; @@ -62,39 +61,33 @@ TRenderForm = class(TForm) cbMaxMemory: TComboBox; chkLimitMem: TCheckBox; Output: TMemo; - ProgressBar2: TdwProgressBar; - PBMem: TdwProgressBar; lblMemory: TLabel; btnBrowse: TSpeedButton; txtFilename: TEdit; GroupBox1: TGroupBox; chkSave: TCheckBox; - chkThreadPriority: TCheckBox; GroupBox6: TGroupBox; chkPostProcess: TCheckBox; chkShutdown: TCheckBox; Label6: TLabel; Label7: TLabel; btnGoTo: TSpeedButton; - cbEXIF: TCheckBox; - en: TImageEnIO; - cbParEXIF: TCheckBox; - chkSaveIncompleteRenders: TCheckBox; pnlWidth: TPanel; pnlHeight: TPanel; pnlDensity: TPanel; pnlFilter: TPanel; pnlOversample: TPanel; pnlLimit: TPanel; - txtAuthor: TEdit; pnlTarget: TPanel; - pnlAuthor: TPanel; - TEST_btnSnapshot: TButton; - cbBitsPerSample: TComboBox; - pnlBufferDepth: TPanel; - TEST_btnUseSnapshot: TButton; - procedure TEST_btnUseSnapshotClick(Sender: TObject); - procedure TEST_btnSnapshotClick(Sender: TObject); + btnDonate: TButton; + btnSaveLog: TButton; + chkBinary: TCheckBox; + ProgressBar2: TProgressBar; + PBMem: TProgressBar; + chkSaveIncompleteRenders: TCheckBox; + lblCPUCores: TLabel; + procedure btnSaveLogClick(Sender: TObject); + procedure btnDonateClick(Sender: TObject); procedure cbMaxMemoryChange(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); @@ -116,10 +109,7 @@ TRenderForm = class(TForm) procedure cmbPresetChange(Sender: TObject); procedure chkMaintainClick(Sender: TObject); procedure chkSaveIncompleteRendersClick(Sender: TObject); - procedure cbBitsPerSampleSelect(Sender: TObject); - procedure chkThreadPriorityClick(Sender: TObject); procedure btnGoToClick(Sender: TObject); - procedure cbEXIFClick(Sender: TObject); private StartTime, EndTime, oldElapsed, edt: TDateTime; oldProg: double; @@ -187,6 +177,7 @@ procedure TRenderForm.ResetControls; chkSaveIncompleteRenders.Enabled := not IsLimitingMemory; btnRender.Enabled := true; cmbPreset.enabled := true; + btnSaveLog.Enabled := false; chkSave.enabled := true; chkPostProcess.enabled := true; chkShutdown.enabled := true; @@ -194,11 +185,14 @@ procedure TRenderForm.ResetControls; btnDeletePreset.enabled := true; btnCancel.Caption := TextByKey('common-close'); btnPause.enabled := false; - cbParExif.Enabled := cbExif.Checked; ProgressBar2.Position := 0; - ProgressBar2.ShowInTaskbar := false; chkMaintain.Enabled := true; + SetTaskbarProgressValue( + ProgressBar2.Position - ProgressBar2.Min, + ProgressBar2.Max - ProgressBar2.Min); + SetTaskbarProgressState(tbpsNone); + pnlWidth.Enabled := true; pnlHeight.Enabled := true; pnlDensity.Enabled := true; @@ -236,6 +230,14 @@ procedure WinShellExecute(const Operation, AssociatedFile: string); ); end; +function GetCpuCount: integer; +var + si: TSystemInfo; +begin; + GetSystemInfo(si); + Result := si.dwNumberOfProcessors; +end; + procedure TRenderForm.ShowMemoryStatus; var GlobalMemoryInfo: TMemoryStatus; // holds the global memory status information @@ -244,18 +246,32 @@ procedure TRenderForm.ShowMemoryStatus; GlobalMemoryStatus(GlobalMemoryInfo); PhysicalMemory := GlobalMemoryInfo.dwAvailPhys div 1048576; TotalPhysicalMemory := GlobalMemoryInfo.dwTotalPhys div 1048576; - TotalPhysicalMemory := TotalPhysicalMemory * 9 div 10; // assume that OS will take 10% of RAM ;) - ApproxMemory := int64(ImageHeight) * int64(ImageWidth) * sqr(Oversample) * SizeOfBucket[BitsPerSample] div 1048576; + //TotalPhysicalMemory := TotalPhysicalMemory * 9 div 10; // assume that OS will take 10% of RAM ;) + + if SingleBuffer then + ApproxMemory := int64(ImageHeight) * int64(ImageWidth) * sqr(Oversample) * 16 div 1048576 + else + ApproxMemory := int64(ImageHeight) * int64(ImageWidth) * sqr(Oversample) * 32 div 1048576; + // lblPhysical.Caption := Format('%u', [PhysicalMemory]) + ' Mb'; // lblApproxMem.Caption := Format('%u', [ApproxMemory]) + ' Mb'; lblMemory.Caption := Format(TextByKey('render-resourceusage-infotext'), [ApproxMemory, PhysicalMemory]); + lblCPUCores.Caption := Format(TextByKey('render-resourceusage-infotext2'), [NrTreads, GetCpuCount]); PBMem.Position := round(100 * (ApproxMemory / PhysicalMemory)); if ApproxMemory > PhysicalMemory then //lblPhysical.Font.Color := clRed - PBMem.ProgressBarState := pbstError + lblMemory.Font.Color := clRed else //lblPhysical.Font.Color := clWindowText; - PBMem.ProgressBarState := pbstNormal; + lblMemory.Font.Color := clWindowText; + + if NrTreads > GetCpuCount then + lblCpuCores.Font.Color := clRed + else + lblCpuCores.Font.Color := clWindowText; + + + //btnRender.Enabled := (ApproxMemory <= PhysicalMemory) or (cbMaxMemory.ItemIndex > 0); if ApproxMemory > 0 then lblMaxbits.caption := format('%2.3f', [8 + log2( @@ -272,24 +288,6 @@ procedure Trace2(const str: string); procedure TRenderForm.Save(const str:string); begin Renderer.SaveImage(FileName); - if cbEXIF.Checked then begin - en.ParamsFromFile(FileName); - en.Params.EXIF_HasExifData := true; - en.Params.EXIF_XPTitle := cp.name; - en.Params.EXIF_XPKeywords := 'Apophysis ' + cp.name; - en.Params.EXIF_XPAuthor := txtAuthor.Text; - en.Params.EXIF_Artist := txtAuthor.text; - en.Params.EXIF_Software := AppVersionString; - en.Params.EXIF_DateTime := FormatDateTime('yyyy.mm.dd hh:nn:ss',Now); - en.Params.EXIF_DateTimeOriginal := en.Params.EXIF_DateTime; - en.Params.EXIF_DateTimeDigitized := en.Params.EXIF_DateTime; - en.Params.EXIF_Make := 'Apophysis'; - en.Params.EXIF_Model := AppVersionString; - if (cbParExif.Checked) then begin - en.Params.EXIF_UserComment := MainForm.RetrieveXML(cp); - end; - en.InjectJpegEXIF(FileName); - end; end; procedure TRenderForm.HandleThreadCompletion(var Message: TMessage); @@ -317,7 +315,7 @@ procedure TRenderForm.HandleThreadCompletion(var Message: TMessage); Output.Lines.Add(TimeToStr(Now) + ' : ' + TextByKey('render-status-saveerror-log')); tryAgain := (Application.MessageBox(PChar(TextByKey('render-status-saveerror-message1') + #13#10 + e.Message + #13#10 + TextByKey('render-status-saveerror-message2')), 'Apophysis', MB_RETRYCANCEL or MB_ICONERROR) = IDRETRY); - ProgressBar2.ProgressBarState := pbstError; + SetTaskbarProgressState(tbpsError); end; end; until tryAgain = false; @@ -335,7 +333,8 @@ procedure TRenderForm.HandleThreadCompletion(var Message: TMessage); Renderer.ShowSmallStats; Output.Lines.Add(' ' + TextByKey('render-status-totaltime') + TimeToString(EndTime - StartTime)); Output.Lines.Add(''); - ProgressBar2.ShowInTaskbar := false; + + SetTaskbarProgressState(tbpsNone); if not IsLimitingMemory and chkPostProcess.checked then DoPostProcess; @@ -343,6 +342,9 @@ procedure TRenderForm.HandleThreadCompletion(var Message: TMessage); Renderer.Free; Renderer := nil; if not bRenderAll then ResetControls; + + btnSaveLog.Enabled := true; + if chkShutdown.Checked and not bRenderAll then WindowsExit; end; @@ -365,12 +367,14 @@ procedure TRenderForm.HandleThreadTermination(var Message: TMessage); Output.Lines.Add(TimeToStr(Now) + ' : ' + TextByKey('render-status-renderterminated')); Output.Lines.Add(''); - ProgressBar2.ShowInTaskbar := false; + SetTaskbarProgressState(tbpsNone); sndPlaySound(pchar(SND_ALIAS_SYSTEMEXCLAMATION), SND_ALIAS_ID or SND_NOSTOP or SND_ASYNC); Renderer.Free; Renderer := nil; ResetControls; + + btnSaveLog.Enabled := true; end; procedure TRenderForm.OnProgress(prog: double); @@ -422,6 +426,12 @@ procedure TRenderForm.OnProgress(prog: double); procedure TRenderForm.FormCreate(Sender: TObject); begin +{$ifdef Apo7X64} + cbMaxMemory.Items.Add('2048'); + cbMaxMemory.Items.Add('3072'); + cbMaxMemory.Items.Add('4096'); +{$endif} + pnlWidth.Caption := TextByKey('common-width'); pnlHeight.Caption := TextByKey('common-height'); GroupBox2.Caption := TextByKey('common-size'); @@ -442,16 +452,13 @@ procedure TRenderForm.FormCreate(Sender: TObject); GroupBox4.Caption := TextByKey('render-resourceusage-title'); pnlLimit.Caption := TextByKey('render-resourceusage-limit'); //pnlBufferDepth.Caption := TextByKey('render-resourceusage-bufferdepth'); - GroupBox1.Caption := TextByKey('render-output-title'); chkSave.Caption := TextByKey('render-output-saveparams'); - cbEXIF.Caption := TextByKey('render-output-writeexif'); - pnlAuthor.Caption := TextByKey('render-output-author'); - cbParEXIF.Caption := TextByKey('render-output-includeparams'); GroupBox6.Caption := TextByKey('render-completion-title'); chkPostProcess.Caption := TextByKey('render-completion-postprocess'); chkShutdown.Caption := TextByKey('render-completion-shutdown'); chkSaveIncompleteRenders.Caption := TextByKey('render-completion-saveincomplete'); cbMaxMemory.Items[0] := TextByKey('render-resourceusage-nolimit') ; + Groupbox1.Caption := TextByKey('render-tab-output-title'); cp := TControlPoint.Create; cbMaxMemory.ItemIndex := 0; @@ -479,18 +486,56 @@ procedure TRenderForm.btnRenderClick(Sender: TObject); iCurrFlame: integer; path, ext: string; lim:integer; + ilm:boolean; + sl: TStringList; + tryAgain: boolean; + cancel: boolean; + result: integer; begin + // overwrite target with 0b file + // this to test writability in output directory + {sl := TStringList.Create; + sl.Text := ''; + repeat + tryAgain := false; + cancel := false; + try + sl.SaveToFile(txtFileName.Text); + except + on e: Exception do begin + Output.Lines.Add(TimeToStr(Now) + ' : ' + TextByKey('render-status-saveerror-log')); + result := (Application.MessageBox(PChar(TextByKey('render-status-saveerror-message1') + #13#10 + e.Message + + #13#10 + TextByKey('render-status-saveerror-message2')), 'Apophysis', MB_RETRYCANCEL or MB_ICONERROR)); + tryAgain := (result = IDRETRY); + cancel := (result = IDCANCEL); + ProgressBar2.ProgressBarState := pbstError; + end; + end; + until (tryAgain = false) or (cancel = true); + sl.Destroy; } + + //if (cancel) then Exit; + Output.Text := ''; + SetTaskbarProgressValue( + ProgressBar2.Position - ProgressBar2.Min, + ProgressBar2.Max - ProgressBar2.Min); + SetTaskbarProgressState(tbpsNormal); + ImageWidth := StrToInt(cbWidth.text); ImageHeight := StrToInt(cbHeight.text); - if (IsLimitingMemory) then lim := StrToInt(cbMaxMemory.text) + ilm := IsLimitingMemory; + if (IsLimitingMemory) then begin + lim := StrToInt(cbMaxMemory.text); + MaxMemory := lim; + end else lim := PhysicalMemory + 1; - if not IsLimitingMemory then begin + if not ilm then begin if (ApproxMemory > {Total}PhysicalMemory) then begin - Application.MessageBox(PAnsiChar(TextByKey('render-status-notenoughmemory1')), 'Apophysis', 48); - exit; + if IDYES <> Application.MessageBox(PChar(TextByKey('render-status-notenoughmemory1')), 'Apophysis', MB_ICONWARNING or MB_YESNO) then + exit; end; { if (ApproxMemory > PhysicalMemory) then @@ -504,56 +549,57 @@ procedure TRenderForm.btnRenderClick(Sender: TObject); } end else if (PhysicalMemory < lim) and (Approxmemory > PhysicalMemory) then begin - Application.MessageBox(PAnsiChar(TextByKey('render-status-notenoughmemory2')), 'Apophysis', 48); - exit; + if IDYES <> Application.MessageBox(PChar(TextByKey('render-status-notenoughmemory2')), 'Apophysis', MB_ICONWARNING or MB_YESNO) then + exit; end; t := txtFilename.Text; if t = '' then begin - Application.MessageBox(PAnsiChar(TextByKey('render-status-nofilename')), 'Apophysis', 48); + Application.MessageBox(PChar(TextByKey('render-status-nofilename')), 'Apophysis', 48); Exit; end; if FileExists(t) then - if Application.MessageBox(PAnsiChar(Format(TextByKey('render-status-fileexists-message1'), [t]) + #13#10 + TextByKey('render-status-fileexists-message2')), + if Application.MessageBox(PChar(Format(TextByKey('render-status-fileexists-message1'), [t]) + #13#10 + TextByKey('render-status-fileexists-message2')), 'Apophysis', 52) = ID_NO then exit; if not DirectoryExists(ExtractFileDir(t)) then begin - Application.MessageBox(PAnsiChar(TextByKey('render-status-pathdoesnotexist')), 'Apophyis', 16); + Application.MessageBox(PChar(TextByKey('render-status-pathdoesnotexist')), 'Apophyis', 16); exit; end; {Check for invalid values } if sample_density <= 0 then begin - Application.MessageBox(PAnsiChar(TextByKey('render-status-invaliddensity')), 'Apophysis', 16); + Application.MessageBox(PChar(TextByKey('render-status-invaliddensity')), 'Apophysis', 16); exit; end; if filter_radius <= 0 then begin - Application.MessageBox(PAnsiChar(TextByKey('render-status-invalidfilterradius')), 'Apophysis', 16); + Application.MessageBox(PChar(TextByKey('render-status-invalidfilterradius')), 'Apophysis', 16); exit; end; if Oversample < 1 then begin - Application.MessageBox(PAnsiChar(TextByKey('render-status-invalidoversample')), 'Apophysis', 16); + Application.MessageBox(PChar(TextByKey('render-status-invalidoversample')), 'Apophysis', 16); exit; end; if ImageWidth < 1 then begin - Application.MessageBox(PAnsiChar(TextByKey('render-status-invalidwidth')), 'Apophysis', 16); + Application.MessageBox(PChar(TextByKey('render-status-invalidwidth')), 'Apophysis', 16); exit; end; if ImageHeight < 1 then begin - Application.MessageBox(PAnsiChar(TextByKey('render-status-invalidheight')), 'Apophysis', 16); + Application.MessageBox(PChar(TextByKey('render-status-invalidheight')), 'Apophysis', 16); exit; end; - if (IsLimitingMemory) then - if StrToInt(cbMaxMemory.text) * 1024*1024 < ImageWidth * (int64(ImageHeight) * 4 + oversample) then begin + if (ilm) then + if lim * 1024*1024 < ImageWidth * (int64(ImageHeight) * 4 + oversample) then begin // Must be enough memory to hold the final image (RGBA) - Application.MessageBox(PAnsiChar(TextByKey('render-status-maxmemorytoosmall')), 'Apophysis', 16); - exit; + if IDYES <> Application.MessageBox(PChar(TextByKey('render-status-maxmemorytoosmall')), 'Apophysis', MB_ICONERROR or MB_YESNO) then + exit; end; + txtFilename.Enabled := false; btnBrowse.Enabled := false; cbWidth.Enabled := False; @@ -571,12 +617,17 @@ procedure TRenderForm.btnRenderClick(Sender: TObject); btnSavePreset.enabled := false; btnDeletePreset.enabled := false; btnRender.Enabled := false; + btnSaveLog.Enabled := false; btnPause.enabled := true; btnCancel.Caption := TextByKey('common-cancel'); - ProgressBar2.ShowInTaskbar := true; chkMaintain.Enabled := false; StartTime := Now; + SetTaskbarProgressValue( + ProgressBar2.Position - ProgressBar2.Min, + ProgressBar2.Max - ProgressBar2.Min); + SetTaskbarProgressState(tbpsNormal); + pnlWidth.Enabled := false; pnlHeight.Enabled := false; pnlDensity.Enabled := false; @@ -627,8 +678,12 @@ procedure TRenderForm.btnRenderClick(Sender: TObject); Output.Lines.Add(' ' + Format(TextByKey('render-status-log-size'), [ImageWidth, ImageHeight])); Output.Lines.Add(' ' + Format(TextByKey('render-status-log-quality'), [sample_density])); Output.Lines.Add(' ' + Format(TextByKey('render-status-log-oversampling'), [oversample, filter_radius])); - Output.Lines.Add(' ' + Format(TextByKey('render-status-log-bufferdepth'), ['32bit integer'(*cbBitsPerSample.Items[BitsPerSample]*)])); - if (not IsLimitingMemory) then + if SingleBuffer then + Output.Lines.Add(' ' + Format(TextByKey('render-status-log-bufferdepth'), ['32 bit float'])) + else + Output.Lines.Add(' ' + Format(TextByKey('render-status-log-bufferdepth'), ['64 bit float'])); + + if (ilm) then Output.Lines.Add(' ' + Format(TextByKey('render-status-log-memorylimit'), [MaxMemory])) else if (UpperCase(ExtractFileExt(FileName)) = '.PNG') and @@ -671,9 +726,10 @@ procedure TRenderForm.btnRenderClick(Sender: TObject); else Renderer.SetPriority(tpNormal); } + Renderer.ExportBuffer := chkBinary.Checked; Renderer.BitsPerSample := BitsPerSample; - if (not IsLimitingMemory) then - Renderer.MaxMem := MaxMemory;//StrToInt(cbMaxMemory.text); + if (ilm) then + Renderer.MaxMem := lim;//StrToInt(cbMaxMemory.text); Renderer.OnProgress := OnProgress; Renderer.TargetHandle := self.Handle; Renderer.SetCP(cp); @@ -696,9 +752,14 @@ procedure TRenderForm.btnRenderClick(Sender: TObject); Output.Lines.Add(' ' + Format(TextByKey('render-status-log-size'), [ImageWidth, ImageHeight])); Output.Lines.Add(' ' + Format(TextByKey('render-status-log-quality'), [sample_density])); Output.Lines.Add(' ' + Format(TextByKey('render-status-log-oversampling'), [oversample, filter_radius])); - Output.Lines.Add(' ' + Format(TextByKey('render-status-log-bufferdepth'), ['32bit integer'(*cbBitsPerSample.Items[BitsPerSample]*)])); - if (not IsLimitingMemory) then - Output.Lines.Add(' ' + Format(TextByKey('render-status-log-memorylimit'), [MaxMemory])) + + if SingleBuffer then + Output.Lines.Add(' ' + Format(TextByKey('render-status-log-bufferdepth'), ['32 bit float'])) + else + Output.Lines.Add(' ' + Format(TextByKey('render-status-log-bufferdepth'), ['64 bit float'])); + + if (ilm) then + Output.Lines.Add(' ' + Format(TextByKey('render-status-log-memorylimit'), [lim])) else if (UpperCase(ExtractFileExt(FileName)) = '.PNG') and (ImageWidth * ImageHeight >= 20000000) then @@ -746,8 +807,9 @@ procedure TRenderForm.btnRenderClick(Sender: TObject); Renderer.SetPriority(tpNormal); } Renderer.BitsPerSample := BitsPerSample; - if (not IsLimitingMemory) then - Renderer.MaxMem := MaxMemory;//StrToInt(cbMaxMemory.text); + if (ilm) then + Renderer.MaxMem := lim;//StrToInt(cbMaxMemory.text); + Renderer.ExportBuffer := chkBinary.Checked; Renderer.OnProgress := OnProgress; Renderer.TargetHandle := self.Handle; // Renderer.Output := Output.Lines; @@ -761,7 +823,7 @@ procedure TRenderForm.btnRenderClick(Sender: TObject); except Output.Lines.Add(TimeToStr(Now) + ' : ' + TextByKey('render-status-rendererror-log')); - Application.MessageBox(PAnsiChar(TextByKey('render-status-rendererror-message')), 'Apophysis', 48); + Application.MessageBox(PChar(TextByKey('render-status-rendererror-message')), 'Apophysis', 48); end; end; end; @@ -804,20 +866,9 @@ procedure TRenderForm.FormShow(Sender: TObject); sample_density := renderDensity; txtDensity.Text := FloatToStr(sample_density); BitsPerSample := renderBitsPerSample; - //cbBitsPerSample.ItemIndex := BitsPerSample; - cbExif.Checked := StoreEXIF; - cbParExif.Enabled := StoreEXIF; - cbParExif.Checked := (StoreExif and StoreParamsExif); - pnlAuthor.Enabled := StoreEXIF; - txtAuthor.Enabled := StoreEXIF; - if (not cbEXIF.Checked) then pnlAuthor.Font.Color := clGrayText - else pnlAuthor.Font.Color := clWindowText; - if (not txtAuthor.Enabled) then txtAuthor.Text := '' - else txtAuthor.Text := ExifAuthor; ShowMemoryStatus; Ratio := ImageWidth / ImageHeight; chkSaveIncompleteRenders.Checked := SaveIncompleteRenders; - chkThreadPriority.Checked := LowerRenderPriority; end; procedure TRenderForm.txtWidthChange(Sender: TObject); @@ -878,15 +929,6 @@ procedure TRenderForm.txtFilenameChange(Sender: TObject); begin filename := txtFilename.text; ext := LowerCase(ExtractFileExt(filename)); - if ((ext = '.jpg') or (ext = '.jpeg')) then begin - cbEXIF.Enabled := true; - cbParEXIF.Enabled := false; - end else begin - cbEXIF.Checked := false; - cbEXIF.Enabled := false; - cbParEXIF.Checked := false; - cbParEXIF.Enabled := false; - end; end; procedure TRenderForm.btnCancelClick(Sender: TObject); @@ -900,7 +942,7 @@ procedure TRenderForm.btnCancelClick(Sender: TObject); end; if ConfirmStopRender then begin - if Application.MessageBox(PAnsiChar(TextByKey('render-status-confirmstop')), 'Apophysis', 36) = ID_NO then exit; + if Application.MessageBox(PChar(TextByKey('render-status-confirmstop')), 'Apophysis', 36) = ID_NO then exit; end; bRenderAll := false; @@ -915,7 +957,10 @@ procedure TRenderForm.btnCancelClick(Sender: TObject); Renderer.WaitFor; //? PageCtrl.TabIndex := 0; end; - ProgressBar2.ProgressBarState := pbstNormal; + SetTaskbarProgressValue( + ProgressBar2.Position - ProgressBar2.Min, + ProgressBar2.Max - ProgressBar2.Min); + SetTaskbarProgressState(tbpsNone); end else Close; end; @@ -952,9 +997,6 @@ procedure TRenderForm.FormClose(Sender: TObject; var Action: TCloseAction); renderDensity := Sample_density; renderOversample := Oversample; renderBitsPerSample := BitsPerSample; - StoreExif := cbExif.Checked; - StoreParamsExif := cbParExif.Checked; - ExifAuthor := txtAuthor.Text; { Write position to registry } Registry := TRegistry.Create; try @@ -975,11 +1017,11 @@ procedure TRenderForm.btnPauseClick(Sender: TObject); if Renderer.Suspended = false then begin renderer.Suspend; btnPause.caption := TextByKey('common-resume'); - ProgressBar2.ProgressBarState := pbstPaused; + SetTaskbarProgressState(tbpsPaused); end else begin renderer.Resume; btnPause.caption := TextByKey('common-pause'); - ProgressBar2.ProgressBarState := pbstNormal; + SetTaskbarProgressState(tbpsNormal); end; end; @@ -987,7 +1029,7 @@ procedure TRenderForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean); begin if Assigned(Renderer) then - if Application.MessageBox(PAnsiChar(TextByKey('render-status-confirmstop')), 'Apophysis', 36) = ID_NO then + if Application.MessageBox(PChar(TextByKey('render-status-confirmstop')), 'Apophysis', 36) = ID_NO then CanClose := False else begin @@ -1048,6 +1090,7 @@ procedure TRenderForm.btnBrowseClick(Sender: TObject); var fn:string; ext:string; + sl:TStringList; begin SaveDialog.Filename := Filename; case renderFileFormat of @@ -1067,16 +1110,7 @@ procedure TRenderForm.btnBrowseClick(Sender: TObject); ext := LowerCase(ExtractFileExt(fn)); if (ext = '.bmp') then renderFileFormat := 1; if (ext = '.png') then renderFileFormat := 2; - if ((ext = '.jpg') or (ext = '.jpeg')) then begin - renderFileFormat := 3; - cbEXIF.Enabled := true; - cbParEXIF.Enabled := false; - end else begin - cbEXIF.Checked := false; - cbEXIF.Enabled := false; - cbParEXIF.Checked := false; - cbParEXIF.Enabled := false; - end; + if ((ext = '.jpg') or (ext = '.jpeg')) then renderFileFormat := 3; {case SaveDialog.FilterIndex of 1: txtFilename.Text := ChangeFileExt(SaveDialog.Filename, '.bmp'); 2: txtFilename.Text := ChangeFileExt(SaveDialog.Filename, '.png'); @@ -1085,6 +1119,7 @@ procedure TRenderForm.btnBrowseClick(Sender: TObject); txtFileName.Text := ChangeFileExt(fn, ext); //renderFileFormat := SaveDialog.FilterIndex; renderPath := ExtractFilePath(SaveDialog.Filename); + end; end; @@ -1190,10 +1225,6 @@ procedure TRenderForm.chkMaintainClick(Sender: TObject); procedure TRenderForm.DoPostProcess; begin frmPostProcess.cp := cp; - frmPostProcess.en := en; - frmPostProcess.author := txtAuthor.text; - frmPostProcess.DoStoreExif := cbExif.Checked; - frmPostProcess.DoStoreExifParams := cbParExif.Checked; frmPostProcess.SetRenderer(Renderer.GetRenderer); frmPostProcess.SetControlPoint(CP); frmPostProcess.SetImageName(FileName); @@ -1247,27 +1278,6 @@ procedure TRenderForm.chkSaveIncompleteRendersClick(Sender: TObject); SaveIncompleteRenders := chkSaveIncompleteRenders.Checked; end; -procedure TRenderForm.cbBitsPerSampleSelect(Sender: TObject); -begin - BitsPerSample := cbBitsPerSample.ItemIndex; - - ShowMemoryStatus; -end; - -procedure TRenderForm.chkThreadPriorityClick(Sender: TObject); -begin - LowerRenderPriority := chkThreadPriority.Checked; - - - {if Assigned(Renderer) then begin - if LowerRenderPriority then - Renderer.SetPriority(tpLower) - else - Renderer.SetPriority(tpNormal); - end;} - -end; - procedure TRenderForm.btnGoToClick(Sender: TObject); var path:string; @@ -1277,43 +1287,31 @@ procedure TRenderForm.btnGoToClick(Sender: TObject); end; - -procedure TRenderForm.cbEXIFClick(Sender: TObject); -begin - if (not cbEXIF.Checked) then cbParExif.Checked := false; - cbParExif.Enabled := cbEXIF.Checked; - pnlAuthor.Enabled := cbEXIF.Checked; - txtAuthor.Enabled := cbExif.Checked; - if (not cbEXIF.Checked) then pnlAuthor.Font.Color := clGrayText - else pnlAuthor.Font.Color := clWindowText; -end; - procedure TRenderForm.cbMaxMemoryChange(Sender: TObject); begin //cbMaxMemory.enabled := IsLimitingMemory; chkPostProcess.Enabled := not IsLimitingMemory; chkSaveIncompleteRenders.Enabled := not IsLimitingMemory; + //btnRender.Enabled := (ApproxMemory <= PhysicalMemory) or (cbMaxMemory.ItemIndex > 0); end; -procedure TRenderForm.TEST_btnSnapshotClick(Sender: TObject); +procedure TRenderForm.btnDonateClick(Sender: TObject); begin - Renderer.HibernateRender('F:\apo_hibernation.bin'); + WinShellExecute('open', 'http://bit.ly/xwdonate'); end; -procedure TRenderForm.TEST_btnUseSnapshotClick(Sender: TObject); +procedure TRenderForm.btnSaveLogClick(Sender: TObject); +var fn: string; sl: TStringList; begin - Renderer := TRenderThread.Create; - assert(Renderer <> nil); - Renderer.BitsPerSample := BitsPerSample; - if (not IsLimitingMemory) then - Renderer.MaxMem := MaxMemory;//StrToInt(cbMaxMemory.text); - Renderer.OnProgress := OnProgress; - Renderer.TargetHandle := self.Handle; - Renderer.SetCP(cp); - Renderer.Priority := tpLower; - Renderer.NrThreads := NrTreads; - Renderer.Output := Output.Lines; - Renderer.ResumeFromHibernation('F:\apo_hibernation.bin'); + if OpenSaveFileDialog(RenderForm, '.log', + Format('Render-Log (*.txt;*.log)|*.txt;*.log|%s|*.*', [TextByKey('common-filter-allfiles')]), + SaveDialog.InitialDir, TextByKey('common-browse'), fn, false, true, false, false) + then begin + sl := TStringList.Create; + sl.Text := Output.Text; + sl.SaveToFile(fn); + sl.Destroy; + end; end; end. diff --git a/Source/Forms/Fullscreen.ddp b/Source/Forms/Fullscreen.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/Fullscreen.ddp and /dev/null differ diff --git a/Source/Forms/ImageColoring.ddp b/Source/Forms/ImageColoring.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/ImageColoring.ddp and /dev/null differ diff --git a/Source/Forms/LoadTracker.ddp b/Source/Forms/LoadTracker.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/LoadTracker.ddp and /dev/null differ diff --git a/Source/Forms/LoadTracker.dfm b/Source/Forms/LoadTracker.dfm index 47a8073..a2e3381 100644 --- a/Source/Forms/LoadTracker.dfm +++ b/Source/Forms/LoadTracker.dfm @@ -1,9 +1,10 @@ object LoadForm: TLoadForm Left = 443 Top = 274 - Width = 552 - Height = 388 + Width = 678 + Height = 426 ActiveControl = Button1 + Anchors = [akLeft, akTop, akRight, akBottom] Caption = 'Messages' Color = clBtnFace Constraints.MinHeight = 275 @@ -53,23 +54,24 @@ object LoadForm: TLoadForm 0000000100000001000000010000000100000001000000010000FFFF0000} OldCreateOrder = False OnCreate = FormCreate + OnResize = FormResize DesignSize = ( - 544 - 361) + 670 + 399) PixelsPerInch = 96 TextHeight = 13 object Bevel1: TBevel - Left = 4 - Top = 4 - Width = 536 - Height = 311 + Left = 7 + Top = 7 + Width = 533 + Height = 308 Anchors = [akLeft, akTop, akRight, akBottom] Style = bsRaised end object Button1: TButton - Left = 424 - Top = 328 - Width = 113 + Left = 527 + Top = 359 + Width = 112 Height = 25 Anchors = [akRight, akBottom] Caption = 'Close' @@ -78,9 +80,9 @@ object LoadForm: TLoadForm end object CheckBox1: TCheckBox Left = 8 - Top = 320 - Width = 281 - Height = 41 + Top = 360 + Width = 384 + Height = 24 Anchors = [akLeft, akRight, akBottom] Caption = 'Automatically open this window when loading flame' TabOrder = 1 @@ -88,8 +90,8 @@ object LoadForm: TLoadForm OnClick = CheckBox1Click end object Button2: TButton - Left = 304 - Top = 328 + Left = 406 + Top = 359 Width = 113 Height = 25 Anchors = [akRight, akBottom] @@ -102,13 +104,12 @@ object LoadForm: TLoadForm Top = 8 Width = 528 Height = 303 - Anchors = [akLeft, akTop, akRight, akBottom] BevelOuter = bvRaised BorderStyle = bsNone Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clBtnText - Font.Height = -11 + Font.Height = -12 Font.Name = 'Courier New' Font.Style = [] ParentFont = False diff --git a/Source/Forms/LoadTracker.pas b/Source/Forms/LoadTracker.pas index f0f8cd1..d787883 100644 --- a/Source/Forms/LoadTracker.pas +++ b/Source/Forms/LoadTracker.pas @@ -36,6 +36,7 @@ TLoadForm = class(TForm) Button2: TButton; Bevel1: TBevel; Output: TMemo; + procedure FormResize(Sender: TObject); procedure Button1Click(Sender: TObject); procedure CheckBox1Click(Sender: TObject); procedure FormCreate(Sender: TObject); @@ -77,4 +78,27 @@ procedure TLoadForm.Button2Click(Sender: TObject); Output.Text := ''; end; +procedure TLoadForm.FormResize(Sender: TObject); +begin + CheckBox1.Left := 2; + Checkbox1.Top := self.ClientHeight - Checkbox1.Height - 2; + CheckBox1.Width := self.ClientWidth - button1.Width - button2.Width - 8; + + Button1.Left := self.ClientWidth - button1.Width - button2.Width - 4; + Button1.Top := self.ClientHeight - Checkbox1.Height - 2 + Checkbox1.Height div 2 - Button1.Height div 2; + + Button2.Left := self.ClientWidth - button2.Width - 2; + Button2.Top := Button1.Top; + + Bevel1.Left := 2; + Bevel1.Top := 2; + Bevel1.Width := self.ClientWidth - 4; + Bevel1.Height := self.ClientHeight - 6 - checkbox1.Height; + + Output.Left := Bevel1.Left + 2; + Output.Top := Bevel1.Top + 2; + Output.Width := Bevel1.Width - 4; + Output.Height := Bevel1.Height -4; +end; + end. diff --git a/Source/Forms/Main.ddp b/Source/Forms/Main.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/Main.ddp and /dev/null differ diff --git a/Source/Forms/Main.dfm b/Source/Forms/Main.dfm index ec44368..2677e8b 100644 --- a/Source/Forms/Main.dfm +++ b/Source/Forms/Main.dfm @@ -1,9 +1,9 @@ object MainForm: TMainForm Left = 265 Top = 172 - Width = 1008 - Height = 732 Caption = 'Apophysis 7X' + ClientHeight = 791 + ClientWidth = 1000 Color = clBtnFace Constraints.MinHeight = 240 Constraints.MinWidth = 320 @@ -2401,13 +2401,13 @@ object MainForm: TMainForm Left = 161 Top = 22 Width = 4 - Height = 637 + Height = 750 end object BackPanel: TPanel Left = 165 Top = 22 Width = 835 - Height = 637 + Height = 750 Align = alClient BevelInner = bvLowered BevelOuter = bvNone @@ -2418,7 +2418,7 @@ object MainForm: TMainForm Left = 1 Top = 1 Width = 833 - Height = 635 + Height = 748 Align = alClient Anchors = [] Center = True @@ -2434,7 +2434,7 @@ object MainForm: TMainForm Left = 0 Top = 22 Width = 161 - Height = 637 + Height = 750 Align = alLeft Alignment = taLeftJustify BevelInner = bvLowered @@ -2447,25 +2447,16 @@ object MainForm: TMainForm Left = 1 Top = 1 Width = 159 - Height = 635 + Height = 748 Align = alClient Brush.Color = clWindow Pen.Color = clWindow end - object ListView: TListView - Left = 8 - Top = 160 - Width = 33 - Height = 33 - Columns = <> - TabOrder = 0 - Visible = False - end object ListView1: TListView Left = 1 Top = 1 Width = 159 - Height = 635 + Height = 748 Align = alClient BorderStyle = bsNone Columns = < @@ -2478,11 +2469,18 @@ object MainForm: TMainForm PopupMenu = ListPopUp TabOrder = 1 OnChange = ListViewChange - OnChanging = ListViewChanging - OnClick = ListView1Click OnEdited = ListViewEdited OnInfoTip = ListViewInfoTip end + object ListView: TListView + Left = 23 + Top = 94 + Width = 33 + Height = 33 + Columns = <> + TabOrder = 0 + Visible = False + end end object cbMain: TCoolBar Left = 0 @@ -2511,12 +2509,10 @@ object MainForm: TMainForm object ToolBar: TToolBar Left = 0 Top = 0 - Width = 996 + Width = 1000 Height = 22 Align = alClient ButtonHeight = 23 - EdgeBorders = [] - Flat = True Images = Buttons ParentShowHint = False ShowHint = True @@ -2683,12 +2679,10 @@ object MainForm: TMainForm item Caption = '1000' end> - ItemHeight = 16 TabOrder = 0 OnExit = tbQualityBoxSet OnKeyPress = tbQualityBoxKeyPress OnSelect = tbQualityBoxSet - DropDownCount = 8 end object ToolButton4: TToolButton Left = 362 @@ -2722,16 +2716,24 @@ object MainForm: TMainForm ImageIndex = 11 OnClick = mnuGradClick end - object ToolButton11: TToolButton + object ToolButton19: TToolButton Left = 439 Top = 0 + Hint = 'Curves' + Caption = 'Curves' + ImageIndex = 69 + OnClick = ToolButton19Click + end + object ToolButton11: TToolButton + Left = 462 + Top = 0 Hint = 'Mutate' Caption = 'ToolButton11' ImageIndex = 17 OnClick = mnuMutateClick end object ToolButton12: TToolButton - Left = 462 + Left = 485 Top = 0 Hint = 'Image size' Caption = 'ToolButton12' @@ -2739,7 +2741,7 @@ object MainForm: TMainForm OnClick = mnuImageSizeClick end object ToolButton13: TToolButton - Left = 485 + Left = 508 Top = 0 Hint = 'Messages' Caption = 'ToolButton13' @@ -2747,7 +2749,7 @@ object MainForm: TMainForm OnClick = ToolButton7Click end object ToolButton14: TToolButton - Left = 508 + Left = 531 Top = 0 Hint = 'Options' Caption = 'ToolButton14' @@ -2755,7 +2757,7 @@ object MainForm: TMainForm OnClick = mnuOptionsClick end object ToolButton15: TToolButton - Left = 531 + Left = 554 Top = 0 Width = 8 Caption = 'ToolButton15' @@ -2763,7 +2765,7 @@ object MainForm: TMainForm Style = tbsSeparator end object tbShowAlpha: TToolButton - Left = 539 + Left = 562 Top = 0 Hint = 'Show transparency' Caption = 'Show Alpha' @@ -2772,7 +2774,7 @@ object MainForm: TMainForm OnClick = tbShowAlphaClick end object tbGuides: TToolButton - Left = 562 + Left = 585 Top = 0 Caption = 'Show guides' Down = True @@ -2781,7 +2783,7 @@ object MainForm: TMainForm OnClick = tbGuidesClick end object ToolButton16: TToolButton - Left = 585 + Left = 608 Top = 0 Width = 8 Caption = 'ToolButton16' @@ -2789,7 +2791,7 @@ object MainForm: TMainForm Style = tbsSeparator end object ToolButton17: TToolButton - Left = 593 + Left = 616 Top = 0 Hint = 'Edit script' Caption = 'ToolButton17' @@ -2797,7 +2799,7 @@ object MainForm: TMainForm OnClick = mnuEditScriptClick end object btnRunScript: TToolButton - Left = 616 + Left = 639 Top = 0 Hint = 'Run script' Caption = 'btnRunScript' @@ -2805,7 +2807,7 @@ object MainForm: TMainForm OnClick = btnRunClick end object btnStopScript: TToolButton - Left = 639 + Left = 662 Top = 0 Hint = 'Stop script' Caption = 'btnStopScript' @@ -2813,7 +2815,7 @@ object MainForm: TMainForm OnClick = mnuStopClick end object ToolButton18: TToolButton - Left = 662 + Left = 685 Top = 0 Width = 8 Caption = 'ToolButton18' @@ -2821,7 +2823,7 @@ object MainForm: TMainForm Style = tbsSeparator end object tbDraw: TToolButton - Left = 670 + Left = 693 Top = 0 Caption = 'tbDraw' Grouped = True @@ -2830,7 +2832,7 @@ object MainForm: TMainForm OnClick = tbDragClick end object ToolButton20: TToolButton - Left = 693 + Left = 716 Top = 0 Caption = 'ToolButton20' Grouped = True @@ -2839,7 +2841,7 @@ object MainForm: TMainForm OnClick = tbRotateClick end object ToolButton21: TToolButton - Left = 716 + Left = 739 Top = 0 Caption = 'ToolButton21' Grouped = True @@ -2848,7 +2850,7 @@ object MainForm: TMainForm OnClick = tbzoomwindowClick end object ToolButton22: TToolButton - Left = 739 + Left = 762 Top = 0 Caption = 'ToolButton22' Grouped = True @@ -2860,7 +2862,7 @@ object MainForm: TMainForm end object BottomDock: TPanel Left = 0 - Top = 659 + Top = 772 Width = 1000 Height = 19 Align = alBottom @@ -2869,7 +2871,7 @@ object MainForm: TMainForm object StatusBar: TStatusBar Left = 0 Top = 0 - Width = 804 + Width = 803 Height = 19 Align = alClient Panels = < @@ -2887,9 +2889,9 @@ object MainForm: TMainForm end> end object pnlLSPFrame: TPanel - Left = 804 + Left = 803 Top = 0 - Width = 196 + Width = 197 Height = 19 Align = alRight BevelOuter = bvNone @@ -2907,11 +2909,11 @@ object MainForm: TMainForm end end object Buttons: TImageList - Left = 8 - Top = 56 + Left = 104 + Top = 280 Bitmap = { - 494C010145004A00040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 - 0000000000003600000028000000400000003001000001002000000000000030 + 494C010146005000500010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 + 0000000000003600000028000000400000002001000001002000000000000020 0100000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 @@ -2920,243 +2922,115 @@ object MainForm: TMainForm 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000B7A2930063493500634935006349 3500634935006349350063493500634935006349350063493500634935006349 - 3500634935006349350063493500634935000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 35006349350063493500634935006349350000000000BBA697FF875C44FF875C + 44FF875C44FF875C44FF875C44FF875C44FF875C44FF875C44FF875C44FF875C + 44FF875C44FF875C44FF875C44FF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000B7A29300C0C0C000FFFFFF008000 8000FFFFFF00C0C0C000FFFFFF00C0C0C000FFFFFF00C0C0C000FFFFFF00C0C0 - C00080008000C0C0C000FFFFFF00634935000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + C00080008000C0C0C000FFFFFF006349350000000000BCA798FFFC8E54FFEF81 + 47FFEA763AFFE77136FFE56F2FFFDE6A2AFFD96123FFD45A1EFFC95617FFC350 + 15FFBC4C14FFB84B15FF875C44FF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000B7A29300FFFFFF00C0C0C0008000 8000C0C0C000FFFFFF00C0C0C000FFFFFF00C0C0C000FFFFFF00C0C0C000FFFF - FF0080008000FFFFFF00C0C0C000634935000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + FF0080008000FFFFFF00C0C0C0006349350000000000BDA899FFFC945EFFFE8C + 51FFFF8344FFFE7B39FFF97530FFF4712BFFEF6A26FFE96120FFE25E1DFFDA5B + 16FFD25415FFBE4C13FF875C44FF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000B7A2930080008000800080008000 8000800080008000800080008000800080008000800080008000800080008000 - 8000800080008000800080008000634935000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 80008000800080008000800080006349350000000000BEAA9AFFFC9A69FFFD91 + 57FFFF8749FFFF7B3BFFFA7831FFF5742BFFF06B27FFEB6321FFE55E1DFFE05D + 17FFD95515FFC14E13FF875C44FF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000B7A29300FFFFFF00C0C0C0008000 8000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF - FF0080008000FFFFFF00C0C0C000634935000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + FF0080008000FFFFFF00C0C0C0006349350000000000C0AB9BFFFCA374FFFE99 + 62FFFF8E50FFFE8343FFFB7936FFF6752CFFF16C27FFEC6422FFE75F1EFFE55D + 18FFDE5614FFC74F13FF875C44FF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000BAA59600C0C0C000FFFFFF008000 8000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF - FF0080008000C0C0C000FFFFFF00634935000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + FF0080008000C0C0C000FFFFFF006349350000000000C2AC9DFF57D546FF47D0 + 32FF34CC1EFF2EC617FF26C310FF1FC00AFF1BB904FF18B401FF19AA00FF16A0 + 00FF159700FF117200FF875C44FF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000BEA99A00FFFFFF00C0C0C0008000 8000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF - FF0080008000FFFFFF00C0C0C000634935000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + FF0080008000FFFFFF00C0C0C0006349350000000000C4AE9FFF6AD75AFF57D3 + 46FF41D02DFF32C71DFF2AC313FF1FC00AFF1BBC03FF19B601FF18AC00FF16A3 + 00FF149B00FF107800FF875C44FF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000C3AE9E00C0C0C000FFFFFF008000 8000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF - FF0080008000C0C0C000FFFFFF00634935000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + FF0080008000C0C0C000FFFFFF006349350000000000C6AFA1FF7CDA6FFF67D6 + 58FF51D240FF3DCC2AFF30C41BFF22C10EFF1CBB05FF17B801FF16AE00FF14A4 + 00FF149D00FF107B00FF875C44FF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000C8B2A300FFFFFF00C0C0C0008000 8000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF - FF0080008000FFFFFF00C0C0C000634935000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + FF0080008000FFFFFF00C0C0C0006349350000000000C7B1A2FF8FDD84FF79DA + 6DFF62D554FF4ECD3DFF3BC728FF2AC213FF1FBD08FF17B801FF17B000FF16A6 + 00FF15A000FF107D00FF875C44FF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000BEA99A0080008000800080008000 8000800080008000800080008000800080008000800080008000800080008000 - 8000800080008000800080008000634935000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 80008000800080008000800080006349350000000000C9B2A3FF7A85E6FF6F78 + E5FF636DE6FF5360E2FF4653DFFF394ADCFF3141D7FF2535D3FF1E2DCFFF182A + CCFF1528C7FF111FB0FF875C44FF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000C3AE9E00C0C0C000FFFFFF008000 8000C0C0C000FFFFFF00C0C0C000FFFFFF00C0C0C000FFFFFF00C0C0C000FFFF - FF0080008000FFFFFF00C0C0C000634935000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + FF0080008000FFFFFF00C0C0C0006349350000000000CAB4A5FF838DE5FF7983 + E4FF6D76E5FF606CE2FF4F5ADFFF4250DBFF3746D7FF2C3AD4FF2130CFFF1A29 + CBFF1427CAFF101EB2FF875C44FF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000C8B2A300FFFFFF00C0C0C0008000 8000FFFFFF00C0C0C000FFFFFF00C0C0C000FFFFFF00C0C0C000FFFFFF00C0C0 - C00080008000C0C0C000FFFFFF00634935000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + C00080008000C0C0C000FFFFFF006349350000000000CBB5A6FF8D95E5FF828D + E4FF777FE3FF6B75E1FF5C6AE0FF4A57DEFF3D4DD8FF313FD5FF2533D1FF1C2A + CDFF1426CAFF0E1FBAFF875C44FF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000EAAA8B00EAAA8B00EAAA8B00EAAA 8B00E9A58400E99F7A00E7976E00E68E6200E5865600E37D4A00E3764000E272 - 3900E2723900E2723900E2723900C8622F000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 3900E2723900E2723900E2723900C8622F0000000000CCB6A7FF959DE4FF8C95 + E4FF818AE2FF757EE3FF6775E0FF5763DDFF4857D8FF3A48D4FF2D3BD1FF2432 + CDFF1629CBFF1020C6FF875C44FF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000EAAA8B00FFC2A200FFC2A200FEC0 9F00FDBD9A00FCB99600FBB59000FAB08B00F9AB8400F8A77D00F6A27700F59D - 7100F5996A00F3956500F3956500CD6531000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 + 7100F5996A00F3956500F3956500CD65310000000000CCB6A7FFCCB6A6FFCAB5 + A5FFC9B3A4FFC8B2A3FFC6B1A2FFC5AFA1FFC3AE9FFFC2AC9DFFC1AB9CFFBFA9 + 9BFFBEA89AFFBDA899FFBCA698FF000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 @@ -5345,12 +5219,8 @@ object MainForm: TMainForm 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000424D3E000000000000003E000000 - 2800000040000000300100000100010000000000800900000000000000000000 - 000000000000000000000000FFFFFF0000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000FFFF0000000000000000000000000000 + 2800000040000000200100000100010000000000000900000000000000000000 + 000000000000000000000000FFFFFF00FFFF0000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 @@ -5426,251 +5296,123 @@ object MainForm: TMainForm 000000000000} end object SmallImages: TImageList - Left = 40 - Top = 56 + Left = 24 + Top = 224 Bitmap = { - 494C010101000500040010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 - 0000000000003600000028000000400000002000000001002000000000000020 - 000000000000000000000000000000000000000000009C636300FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF009C636300FFFFFF00FFFFFF00FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00CECE - CE0000000000000000000000000000000000FF6331000000000000000000FF63 - 310000000000000000000000000000636300639C9C000063630000313100CECE - CE00CEFFFF00FFFFFF009CCECE009CCECE009CCECE0031313100000000000000 - 00000000000063636300FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF00CEFFFF00CEFFFF00CEFFFF00CEFFFF00CEFF - FF009CFFFF000000000000000000000000009CCECE000063630031000000CEFF - FF00CECECE00CECECE00CEFFFF00FF6331003131310000000000000000000000 - 00000000000063636300FFFFFF003100FF003100FF0000006300FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00CEFFFF00CEFFFF00CEFF - FF00CEFFFF000000000000000000000000000000000000000000000000000000 - 00000000000000000000FFFFFF00636363006363630063636300636363006363 - 6300636363006363630063636300636363006363630063636300636363006363 - 630063636300000000000000000000000000FFFFFF00FFFFFF00FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000000000000000000000000000 - 000000000000FFFFFF00FF000000FF000000CEFFFF00CEFFFF00CEFFFF00FF00 - 0000630000009CFFFF009CFFFF0000FFFF0000FFFF0000000000000000000000 - 000000000000000000000000000000000000FFFFFF00FFFFFF00FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00000000009C636300FFFFFF00FFFF - FF00FF9C3100FFFFFF00FFFFFF009C636300FFFFFF00FFFFFF00FF9C3100FF9C - 3100FF9C3100FF9C3100FF633100FF633100FF633100FF633100FFFFFF00CECE - CE0000000000000000000000000000000000FF63310000000000000000000000 - 000000000000000000000000000000636300000000009C636300FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF009C636300FFFFFF00FFFFFF00FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00CECE - CE0000000000000000000000000000000000FF63310000000000000000000000 - 0000000000000000000000000000006363009CCECE00639C9C00006363000063 - 6300CEFFFF00CEFFFF00CECECE009CCECE000000000000000000000000000000 - 00000000000063636300FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00CEFF - FF00FFFFFF00000000000000000000000000006363009CCECE00639C9C00639C - 9C0000636300CECECE00CEFFFF00CECECE003131310000000000000000000000 - 0000000000006363630063636300636363006363630063636300636363006363 - 6300636363006363630063636300636363006363630063636300636363006363 - 6300636363000000000000000000000000000000000000000000000000000000 - 00009C9C9C00FFFFFF00FFFFFF00FFFFFF0063000000FFFFFF00CEFFFF00CEFF - FF00CEFFFF00FF0000009C0000009CFFFF0000FFFF0000000000000000000000 - 000000000000000000000000000000000000FFFFFF00FFFFFF00FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000000000000000000000000000 - 0000000000009C9C9C009C9C9C00FFFFFF00FFFFFF00FFFFFF00FFFFFF00CEFF - FF00CEFFFF00CEFFFF00CEFFFF009CFFFF000000000000000000000000000000 - 000000000000000000000000000000000000FFFFFF00FFFFFF00FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00000000009C636300FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF009C636300FFFFFF00FFFFFF00FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00CECE - CE000000000000000000000000000000000000000000FF633100000000000000 - 0000000000000000000000000000000000000000000063000000630000006300 - 0000630000006300000063000000630000006300000063000000630000006300 - 0000630000006300000063000000630000006300000063000000630000006300 + 494C010101004400440010001000FFFFFFFFFF10FFFFFFFFFFFFFFFF424D3600 + 0000000000003600000028000000400000001000000001002000000000000010 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000006363009CCECE009CCECE00639C - 9C00639C9C000063630000636300313131000063630000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000636300006363009CCE - CE009CCECE00639C9C00639C9C00006363000063630000000000000000000000 - 0000000000000000000000000000000000000000000000000000630000009C00 - 00009C0000006300000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000009C9C9C009C9C9C00FFFFFF00FFFFFF00FFFF - FF00CEFFFF00CEFFFF00CEFFFF00CEFFFF000000000000000000000000000000 - 000000000000000000000000000000000000FFFFFF00FFFFFF00FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000000000000000000000000000 - 000000000000000000000000000000000000000000009C9C9C009C9C9C00FFFF - FF00FFFFFF00FFFFFF00CEFFFF00000000000000000000000000000000000000 - 000000000000000000000000000000000000FFFFFF00FFFFFF00FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0000000000FF000000FFFF3100FF9C - 3100FF9C3100FF633100FF633100FF633100FF633100FF633100FF633100FF63 - 3100FF633100FF633100FF633100FF633100FF633100FF633100FF633100FF63 - 3100000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000000000000000000000000000FF000000FF000000FF00 - 0000FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF00 - 0000FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF00 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000063 - 6300006363000063630000636300000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000006300 - 0000CE0031009C00000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000FF6331000000000000000000FF000000CE00 - 3100CE0031006300000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000009C9C - 9C009C9C9C00FFFFFF00CEFFFF00000000000000000000000000000000000000 - 000000000000000000000000000000000000FFFFFF00FFFFFF00FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000009C9C9C0000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FFFFFF00FFFFFF00FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF + FF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEF + FF00CEEFFF00CEEFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF + FF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEF + FF00CEEFFF00CEEFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 000000000000000000000000000000000000FF633100FF000000FF000000FF00 - 0000000000009C00000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF + FF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEF + FF00CEEFFF00CEEFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000000000000084 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF + FF00296BAD00296BAD00296BAD00296BAD00296BAD00296BAD00296BAD00296B + AD00CEEFFF00CEEFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 00000000FF0000FFFF000063FF00000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF + FF000000000008297B005A9CBD000000000008185A000000000000000000296B + AD00CEEFFF00CEEFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000636300CEFFFF0000CEFF0000CEFF00009CCE0000CE - FF00009CCE0000CEFF00009CCE00009CCE00639C9C00009CCE00639C9C00009C - CE0000000000000000000000000000000000000000000000000000009C000000 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF + FF0000000000184A9C004A8CBD00185A9C00397BAD000000080000000000296B + AD00CEEFFF00CEEFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000009C00000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF + FF0008185A00396BAD00296BAD00185A9C004A8CBD00295A9C0000000000296B + AD00CEEFFF00CEEFFF0000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF - FF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEF - FF00CEEFFF00CEEFFF0000000000000000000000000000000000000000000000 + FF005A9CCE00396BAD0008397B0000081800084A8C008CBDDE00296BAD00296B + AD00CEEFFF00CEEFFF0000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000FFF7EF00FFF7E700FFF7EF00FFF7EF00FFF7 - EF00FFF7F700FFFFF70000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF - FF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEF - FF00CEEFFF00CEEFFF000000000000000000000000000000000031638C003163 - 8C00000000000000000000000000000000000000000000000000DEDEDE00DEDE - DE000000000031638C0000000000000000000000000031638C0031638C000000 - 0000000000000000000000000000FFF7E700D6632100D6733100D6733100D663 - 1000D6632100FFF7EF0000000000000000000000000000000000FFFFFF00FFFF - FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0000000000000000000000 - 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF - FF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEF - FF00CEEFFF00CEEFFF000000000000000000000000000000000031638C003163 - 8C00000000000000000000000000000000000000000000000000DEDEDE00DEDE - DE000000000031638C0000000000000000000000000031638C0031638C000000 - 0000000000000000000000000000FFEFE700E7A57B00FFFFE700FFF7E700FFAD - 6B00E7AD8400FFEFDE0000000000000000000000000000000000FFFFFF006BB5 - E700F7FFFF006BB5E7006BB5E7006BB5E700F7FFFF0000000000000000000000 - 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF - FF00296BAD00296BAD00296BAD00296BAD00296BAD00296BAD00296BAD00296B - AD00CEEFFF00CEEFFF000000000000000000000000000000000031638C003163 - 8C00000000000000000000000000000000000000000000000000DEDEDE00DEDE - DE000000000031638C0000000000000000000000000031638C0031638C000000 - 0000000000000000000000000000FFE7DE00E7945A00FFF7EF00FFCEAD00FFCE - AD00E78C4A00FFE7D60000000000000000000000000000000000F7FFFF00EFFF - FF00E7F7FF000000000000000000000000000000000000000000000000000000 - 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF - FF000000000008297B005A9CBD000000000008185A000000000000000000296B - AD00CEEFFF00CEEFFF000000000000000000000000000000000031638C003163 - 8C00000000000000000000000000000000000000000000000000000000000000 - 00000000000031638C0000000000000000000000000031638C0031638C000000 - 0000000000000000000000000000FFE7D600E7844200FFFFFF00FFB59400FFE7 - CE00E78C5200FFE7CE0000000000000000000000000000000000F7FFFF0063B5 - E70063B5E70000000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF - FF00FFFFFF000000000000000000000000000000000000000000CEEFFF00CEEF - FF0000000000184A9C004A8CBD00185A9C00397BAD000000080000000000296B - AD00CEEFFF00CEEFFF000000000000000000000000000000000031638C003163 - 8C0031638C0031638C0031638C0031638C0031638C0031638C0031638C003163 - 8C0031638C0031638C0000000000000000000000000031638C0031638C003163 - 8C0031638C0031638C0000000000FFDECE00E7843900FFFFF700FFC69C00FFD6 - A500F7B58C00FFDECE0000000000000000000000000000000000EFFFFF00DEF7 - FF00CEEFFF0000000000FFFFFF006BB5E700F7FFFF006BB5E7006BB5E7006BB5 - E700F7FFFF000000000000000000000000000000000000000000CEEFFF00CEEF - FF0008185A00396BAD00296BAD00185A9C004A8CBD00295A9C0000000000296B - AD00CEEFFF00CEEFFF000000000000000000000000000000000031638C003163 - 8C00000000000000000000000000000000000000000000000000000000000000 - 000031638C0031638C0000000000000000000000000031638C0031638C000000 - 0000000000000000000000000000FFDEC600E78C4200FFFFFF00FFFFF7000000 - 0000000000000000000000000000000000000000000000000000EFFFFF005AB5 - E7005AADE70000000000F7FFFF00EFFFFF00E7F7FF00E7F7FF00E7F7FF00E7F7 - FF00E7F7FF000000000000000000000000000000000000000000CEEFFF00CEEF - FF005A9CCE00396BAD0008397B0000081800084A8C008CBDDE00296BAD00296B - AD00CEEFFF00CEEFFF000000000000000000000000000000000031638C000000 - 0000DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDE - DE000000000031638C0000000000000000000000000031638C0000000000DEDE - DE00DEDEDE00DEDEDE0000000000FFDEC600D6631800D6733900E77B39000000 - 0000F7A57B000000000000000000000000000000000000000000EFF7FF00CEEF - FF00BDE7FF0000000000F7FFFF0063B5E70063B5E700DEF7FF0063B5E70063B5 - E700DEF7FF000000000000000000000000000000000000000000CEEFFF00CEEF FF0000000000397BAD00296BAD00396BAD004A7BBD006BADCE0008083900296B - AD00CEEFFF00CEEFFF000000000000000000000000000000000031638C000000 - 0000DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDE - DE000000000031638C0000000000000000000000000031638C0000000000DEDE - DE00DEDEDE00DEDEDE0000000000FFE7D600FFDEC600FFD6C600FFD6C6000000 - 0000000000000000000000000000000000000000000000000000EFFFFF0063B5 - E700C6EFFF0000000000EFFFFF00DEF7FF00CEEFFF00CEEFFF00CEEFFF00D6F7 - FF00DEF7FF000000000000000000000000000000000000000000CEEFFF00CEEF + AD00CEEFFF00CEEFFF0000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF FF00000000000000000008296B007BADCE007BADCE00184A9C0000082900296B - AD00CEEFFF00CEEFFF000000000000000000000000000000000031638C000000 - 0000DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDE - DE000000000031638C0000000000000000000000000031638C0000000000DEDE - DE00DEDEDE00DEDEDE0000000000000000000000000000000000000000000000 - 000031638C000000000000000000000000000000000000000000F7FFFF00EFF7 - FF00E7F7FF0000000000EFFFFF005AB5E7005AADE700C6EFFF00CEEFFF0063B5 - E700EFF7FF000000000000000000000000000000000000000000CEEFFF00CEEF + AD00CEEFFF00CEEFFF0000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF FF0000000000000000000000000008185A00000818000008290000081800296B - AD00CEEFFF00CEEFFF000000000000000000000000000000000031638C000000 - 0000DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDE - DE000000000031638C0000000000000000000000000031638C0000000000DEDE - DE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE000000 - 000031638C000000000000000000000000000000000000000000000000000000 - 00000000000000000000EFF7FF00CEEFFF00BDE7FF00BDE7FF00000000000000 + AD00CEEFFF00CEEFFF0000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF FF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF000000 - 000000000000000000000000000000000000000000000000000031638C000000 - 0000DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDE - DE00000000000000000000000000000000000000000031638C0000000000DEDE - DE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE000000 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000EFFFFF0063B5E700C6EFFF00C6EFFF0000000000C6EF - FF00000000000000000000000000000000000000000000000000CEEFFF00CEEF + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF FF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF000000 - 0000ADCEEF00000000000000000000000000000000000000000031638C000000 - 0000DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDE - DE00000000000000000000000000000000000000000031638C0000000000DEDE - DE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE00DEDEDE000000 + 0000ADCEEF000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 + 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 - 00000000000000000000F7FFFF00EFF7FF00E7F7FF00E7F7FF00000000000000 0000000000000000000000000000000000000000000000000000CEEFFF00CEEF FF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF00CEEFFF000000 0000000000000000000000000000000000000000000000000000000000000000 @@ -5688,22 +5430,18 @@ object MainForm: TMainForm 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000000000000000000000000000000000000424D3E000000000000003E000000 - 2800000040000000200000000100010000000000000100000000000000000000 - 000000000000000000000000FFFFFF00DDE6EA00BBCCD500BBCCD500BBCCD500 - BBCCD500BBCCD500BBCCD500BBCCD500BBCCD500BBCCD500BBCCD500BBCCD500 - 0000000000000000BBCCD500BBCCD500BBCCD500BBCCD500BBCCD500BBCCD500 - BBCCD500BBCCD500BBCCD500BBCCD500BBCCD500BBCCD500BBCCD500BBCCD500 - BBCCD500BBCCD500BBCCD500BBCCD5008001D500BBCCD5008001D500BBCCD500 - 8001D500BBCCD5008001D500BBCCD5008001D500BBCCD5008001D500BBCCD500 - 8001D500BBCCD5008001D500BBCCD5008001EA00BBCCD5008001EA00BBCCD500 - 8001EA00BBCCD5008001EA00BBCCD5008001EA00BBCCD5008003EA00BBCCD500 - 8007EA00BBCCD500800FEA00BBCCD50000000000000000000000000000000000 + 2800000040000000100000000100010000000000800000000000000000000000 + 000000000000000000000000FFFFFF0080010000000000008001000000000000 + 8001000000000000800100000000000080010000000000008001000000000000 + 8001000000000000800100000000000080010000000000008001000000000000 + 8001000000000000800100000000000080010000000000008003000000000000 + 8007000000000000800F00000000000000000000000000000000000000000000 000000000000} end object MainMenu: TMainMenu Images = Buttons - Left = 72 - Top = 56 + Left = 24 + Top = 168 object MainFile: TMenuItem Caption = '&File' OnClick = MainFileClick @@ -5902,6 +5640,12 @@ object MainForm: TMainForm ShortCut = 118 OnClick = mnuMutateClick end + object mnuCurves: TMenuItem + Caption = 'Curves' + ImageIndex = 69 + ShortCut = 119 + OnClick = ToolButton19Click + end object N5: TMenuItem Caption = '-' end @@ -6081,13 +5825,20 @@ object MainForm: TMainForm Hint = 'Show or hide the file contents list' OnClick = mnuFileContentsClick end - object N14: TMenuItem + object N17: TMenuItem Caption = '-' end object mnuResetUI: TMenuItem Caption = 'Reset file content list width' OnClick = mnuResetUIClick end + object N14: TMenuItem + Caption = '-' + end + object mnuTrace: TMenuItem + Caption = 'Trace log...' + OnClick = mnuTraceClick + end object mnuOptions: TMenuItem Caption = 'Options...' Hint = 'Show the Options dialog' @@ -6129,12 +5880,12 @@ object MainForm: TMainForm 'Apophysis Parameter Files (*.apo)|*.apo|Apophysis 1.0 Parameters' + ' (*fla)|*.fla|IFS Files (*.ifs)|*.ifs' Options = [ofHideReadOnly, ofPathMustExist, ofFileMustExist, ofEnableSizing] - Left = 104 - Top = 88 + Left = 24 + Top = 456 end object ListPopUp: TPopupMenu - Left = 40 - Top = 88 + Left = 104 + Top = 168 object mnuItemDelete: TMenuItem Caption = '&Delete' Hint = 'Deletes the selected IFS from the file.' @@ -6150,8 +5901,8 @@ object MainForm: TMainForm end object DisplayPopup: TPopupMenu Images = Buttons - Left = 8 - Top = 88 + Left = 104 + Top = 120 object mnuPopUndo: TMenuItem Caption = 'Undo' Enabled = False @@ -6189,59 +5940,44 @@ object MainForm: TMainForm Enabled = False Interval = 50 OnTimer = RedrawTimerTimer - Left = 104 - Top = 56 + Left = 24 + Top = 336 end object SaveDialog: TSaveDialog DefaultExt = 'bmp' Filter = 'Bitmap Files|*.bmp' Options = [ofOverwritePrompt, ofHideReadOnly, ofEnableSizing] - Left = 72 - Top = 88 + Left = 104 + Top = 400 end object ApplicationEvents: TApplicationEvents OnActivate = ApplicationEventsActivate - Left = 8 - Top = 120 - end - object ListXmlScanner: TEasyXmlScanner - Normalize = True - OnStartTag = ListXmlScannerStartTag - Left = 40 - Top = 120 - end - object XmlScanner: TXmlScanner - Normalize = False - OnStartTag = XMLScannerStartTag - OnEmptyTag = XMLScannerEmptyTag - OnEndTag = XmlScannerEndTag - OnContent = XmlScannerContent - Left = 72 - Top = 120 + Left = 104 + Top = 456 end object Thumbnails: TImageList Height = 128 Masked = False Width = 128 - Left = 40 - Top = 152 + Left = 24 + Top = 280 end object SmallThumbnails: TImageList Height = 96 Masked = False Width = 96 Left = 104 - Top = 152 + Top = 224 end object ColorDialog: TColorDialog Options = [cdFullOpen] - Left = 104 - Top = 120 + Left = 24 + Top = 400 end object AutoSaveTimer: TTimer Enabled = False OnTimer = AutoSaveTimerTimer - Left = 72 - Top = 150 + Left = 104 + Top = 334 end end diff --git a/Source/Forms/Main.pas b/Source/Forms/Main.pas index 439d4d1..0e16c8c 100644 --- a/Source/Forms/Main.pas +++ b/Source/Forms/Main.pas @@ -33,14 +33,13 @@ interface Windows, Forms, Dialogs, Menus, Controls, ComCtrls, ToolWin, StdCtrls, Classes, Messages, ExtCtrls, ImgList, Jpeg, SyncObjs, SysUtils, ClipBrd, Graphics, Math, - ExtDlgs, AppEvnts, ShellAPI, Registry, + ExtDlgs, AppEvnts, ShellAPI, Registry, Curves, Global, Xform, XFormMan, ControlPoint, CMap, - RenderThread, RenderTypes, (*ParameterIO,*) - LibXmlParser, LibXmlComps, PngImage, XPMan, dwTaskbarComponents, - dwTaskbarThumbnails, StrUtils, LoadTracker, CheckLst, - CommandLine, PerlRegEx, MissingPlugin, Base64, Translation, - Mapm, MapmMonitor, MapmPlugin, MapmException, - RegexHelper;//, WinInet; + RenderThread, RenderingCommon, RenderingInterface, (*ParameterIO,*) + LibXmlParser, LibXmlComps, PngImage, XPMan, + StrUtils, LoadTracker, CheckLst, + CommandLine, RegularExpressionsCore, MissingPlugin, Base64, Translation, + RegexHelper, Chaotica;//, WinInet; const PixelCountMax = 32768; @@ -166,9 +165,7 @@ TMainForm = class(TForm) N20: TMenuItem; mnuExportFLame: TMenuItem; mnuPostSheep: TMenuItem; - ListXmlScanner: TEasyXmlScanner; N21: TMenuItem; - XmlScanner: TXmlScanner; mnuFlamepdf: TMenuItem; mnuimage: TMenuItem; mnuSaveAllAs: TMenuItem; @@ -240,8 +237,11 @@ TMainForm = class(TForm) mnuExportChaotica: TMenuItem; mnuResumeRender: TMenuItem; mnuManual: TMenuItem; + ToolButton19: TToolButton; + mnuCurves: TMenuItem; + N17: TMenuItem; + mnuTrace: TMenuItem; procedure mnuManualClick(Sender: TObject); - procedure mnuExportChaoticaClick(Sender: TObject); procedure mnuReportFlameClick(Sender: TObject); procedure mnuTurnFlameToScriptClick(Sender: TObject); procedure tbzoomoutwindowClick(Sender: TObject); @@ -317,6 +317,7 @@ TMainForm = class(TForm) procedure mnuPasteClick(Sender: TObject); procedure mnuCopyClick(Sender: TObject); procedure mnuExportFlameClick(Sender: TObject); + procedure mnuExportChaoticaClick(Sender: TObject); procedure ListXmlScannerStartTag(Sender: TObject; TagName: string; Attributes: TAttrList); @@ -348,7 +349,6 @@ TMainForm = class(TForm) var InfoTip: String); procedure btnViewIconsClick(Sender: TObject); procedure btnViewListClick(Sender: TObject); - procedure TBThumbThumbnailClick(Sender: TdwTaskbarThumbnailItem); procedure ListView1Click(Sender: TObject); procedure XmlScannerEndTag(Sender: TObject; TagName: String); procedure ToolButton7Click(Sender: TObject); @@ -359,9 +359,15 @@ TMainForm = class(TForm) procedure AutoSaveTimerTimer(Sender: TObject); procedure Restorelastautosave1Click(Sender: TObject); procedure tbGuidesClick(Sender: TObject); + procedure ToolButton19Click(Sender: TObject); + procedure mnuTraceClick(Sender: TObject); private + SubstSource: TStringList; + SubstTarget: TStringList; + Renderer: TRenderThread; + FNrThreads: integer; FMouseMoveState: TMouseMoveState; FSelectRect, FClickRect: TRect; @@ -387,14 +393,13 @@ TMainForm = class(TForm) camDragPos, camDragOld: TPoint; camDragValueX, camDragValueY: double; + procedure CreateSubstMap; procedure InsertStrings; procedure DrawImageView; procedure DrawZoomWindow; procedure DrawRotatelines(Angle: double); procedure DrawPitchYawLines(YawAngle: double; PitchAngle:double); - function GetExportChaoticaCP(var fn: string; var cp1: TControlPoint) : boolean; - procedure FillVariantMenu; procedure VariantMenuClick(Sender: TObject); @@ -418,14 +423,20 @@ TMainForm = class(TForm) UsedThumbnails: TImageList; ParseLoadingBatch : boolean; SurpressHandleMissingPlugins : boolean; + LastCaptionSel, LastCaptionFoc: string; + LastDecision: boolean; VarMenus: array of TMenuItem; + ListXmlScanner : TEasyXmlScanner; + XmlScanner : TXmlScanner; + + function ReadWithSubst(Attributes: TAttrList; attrname: string): string; procedure InvokeLoadXML(xmltext:string); procedure LoadXMLFlame(filename, name: string); procedure DisableFavorites; procedure EnableFavorites; - procedure ParseXML(var cp1: TControlPoint; const params: PCHAR; const ignoreErrors : boolean); + procedure ParseXML(var cp1: TControlPoint; const params: string; const ignoreErrors : boolean); function SaveFlame(cp1: TControlPoint; title, filename: string): boolean; function SaveXMLFlame(const cp1: TControlPoint; title, filename: string): boolean; procedure DisplayHint(Sender: TObject); @@ -449,10 +460,6 @@ TMainForm = class(TForm) function SystemErrorMessage: string; function SystemErrorMessage2(errno:cardinal): string; function RetrieveXML(cp : TControlPoint):string; - -{$IFDEF DEBUG} - procedure AppException(Sender: TObject; E: Exception); -{$ENDIF} end; procedure ListXML(FileName: string; sel: integer); @@ -478,6 +485,7 @@ function LoadXMLFlameText(filename, name: string) : string; MainForm: TMainForm; pname, ptime: string; nxform: integer; + TbBreakWidth: integer; EnumPlugins: Boolean; MainCp: TControlPoint; @@ -488,43 +496,22 @@ function LoadXMLFlameText(filename, name: string) : string; UpdateError:boolean; AboutToExit:boolean; - KnownPlugins: TList; - ApophysisSVN:string; //APP_VERSION; AppVersionString:string; //APP_NAME+'.'+APP_VERSION; - procedure MapmPluginAdd(sender: TObject; plugin: HPLUGIN); - procedure MapmPluginRemove(sender: TObject; plugin: HPLUGIN); - implementation uses -{$IFDEF DEBUG} - JclDebug, ExceptForm, -{$ENDIF} - Editor, Options, Regstry, Render, Template, + Editor, Options, Regstry, Template, FullScreen, FormRender, Mutate, Adjust, Browser, Save, About, CmapData, - (*HtmlHlp,*) ScriptForm, FormFavorites, FormExport, - (*ImageColoring,*) RndFlame, - Tracer, Types, SplashForm, FormExportC; + {$ifdef DisableScripting} + {$else} + ScriptForm, FormFavorites, + {$endif} + FormExport, RndFlame, Tracer, Types, SplashForm, varGenericPlugin; {$R *.DFM} -procedure MapmPluginAdd(sender: TObject; plugin: HPLUGIN); -var info : PLUGININFO; -begin - info := MapmCreateZeroPluginInfo; - MapmCheck(PluginGetInfo(plugin, @info)); - if EnumPlugins then - SplashWindow.SetInfo('Loading ' + info.DisplayName + '...'); - KnownPlugins.Add(Pointer(plugin)); - Application.ProcessMessages; -end; -procedure MapmPluginRemove(sender: TObject; plugin: HPLUGIN); -begin - KnownPlugins.Remove(Pointer(plugin)); -end; - procedure AssignBitmapProperly(var Bitmap:TBitmap; Source:TBitmap); begin Bitmap.Dormant; @@ -703,6 +690,8 @@ procedure TMainForm.RebuildListView; end; ListView.Items.Clear; + + end; procedure TMainForm.InsertStrings; @@ -754,6 +743,8 @@ procedure TMainForm.InsertStrings; ToolButton12.Hint := TextByKey('main-menu-view-imagesize'); mnuMessages.Caption := TextByKey('main-menu-view-messages'); toolButton13.Hint := TextByKey('main-menu-view-messages'); + ToolButton19.Hint := TextByKey('main-menu-view-curves'); + mnuCurves.Caption := TextByKey('main-menu-view-curves'); F1.Caption := TextByKey('main-menu-flame-title'); mnuResetLocation.Caption := TextByKey('main-menu-flame-reset'); mnuPopResetLocation.Caption := TextByKey('main-menu-flame-reset'); @@ -1157,7 +1148,8 @@ procedure TMainForm.OnProgress(prog: double); procedure TMainForm.UpdateUndo; begin MainCp.FillUsedPlugins; - SaveFlame(MainCp, Format('%.4d-', [UndoIndex]) + MainCp.name, AppPath + undoFilename); + SaveFlame(MainCp, Format('%.4d-', [UndoIndex]) + MainCp.name, + GetEnvVarValue('APPDATA') + '\' + undoFilename); Inc(UndoIndex); UndoMax := UndoIndex; //Inc(UndoMax); mnuSaveUndo.Enabled := true; @@ -1326,7 +1318,7 @@ function SaveUPR(Entry, FileName: string): boolean; CloseFile(UPRFile); except on E: EInOutError do begin - Application.MessageBox(PAnsiChar(Format(TextByKey('common-genericsavefailure'), [FileName])), 'Apophysis', 16); + Application.MessageBox(PChar(Format(TextByKey('common-genericsavefailure'), [FileName])), 'Apophysis', 16); Result := False; end; end; @@ -1473,7 +1465,7 @@ function StringToIFS(strng: string): boolean; except on E: EFormatInvalid do begin - Application.MessageBox(PAnsiChar(TextByKey('common-invalidformat')), PChar('Apophysis'), 16); + Application.MessageBox(PChar(TextByKey('common-invalidformat')), PChar('Apophysis'), 16); end; end; finally @@ -1520,7 +1512,7 @@ function SaveIFS(cp: TControlPoint; Title, FileName: string): boolean; CloseFile(IFile); except on E: EInOutError do begin - Application.MessageBox(PAnsiChar(Format(TextByKey('common-genericsavefailure'), [FileName])), 'Apophysis', 16); + Application.MessageBox(PChar(Format(TextByKey('common-genericsavefailure'), [FileName])), 'Apophysis', 16); Result := False; end; end; @@ -1564,7 +1556,7 @@ function TMainForm.SaveFlame(cp1: TControlPoint; title, filename: string): boole except on EInOutError do begin - Application.MessageBox(PAnsiChar(Format(TextByKey('common-genericsavefailure'), [FileName])), 'Apophysis', 16); + Application.MessageBox(PChar(Format(TextByKey('common-genericsavefailure'), [FileName])), 'Apophysis', 16); Result := False; end; end; @@ -1605,7 +1597,7 @@ function FlameToXMLAS(const cp1: TControlPoint; title: string; exporting: boolea FileList: TStringList; x, y: double; parameters: string; - str: string; + curves, str: string; begin FileList := TStringList.create; x := cp1.center[0]; @@ -1677,7 +1669,29 @@ function FlameToXMLAS(const cp1: TControlPoint; title: string; exporting: boolea if (i = cp1.used_plugins.Count-1) then break; str := str + ' '; end; - parameters := parameters + format('plugins="%s" ', [str]); + parameters := parameters + format('plugins="%s" new_linear="1" ', [str]); + + for i := 0 to 3 do + begin + curves := curves + FloatToStr(cp1.curvePoints[i][0].x) + ' '; + curves := curves + FloatToStr(cp1.curvePoints[i][0].y) + ' '; + curves := curves + FloatToStr(cp1.curveWeights[i][0]) + ' '; + + curves := curves + FloatToStr(cp1.curvePoints[i][1].x) + ' '; + curves := curves + FloatToStr(cp1.curvePoints[i][1].y) + ' '; + curves := curves + FloatToStr(cp1.curveWeights[i][1]) + ' '; + + curves := curves + FloatToStr(cp1.curvePoints[i][2].x) + ' '; + curves := curves + FloatToStr(cp1.curvePoints[i][2].y) + ' '; + curves := curves + FloatToStr(cp1.curveWeights[i][2]) + ' '; + + curves := curves + FloatToStr(cp1.curvePoints[i][3].x) + ' '; + curves := curves + FloatToStr(cp1.curvePoints[i][3].y) + ' '; + curves := curves + FloatToStr(cp1.curveWeights[i][3]) + ' '; + end; + + curves := trim(curves); + parameters := parameters + format('curves="%s" ', [curves]); FileList.Add(''); { Write transform parameters } @@ -1759,13 +1773,13 @@ function GetThumbnailBase64(const cp1: TControlPoint) : string; result := base64; end; -function FlameToXML(const cp1: TControlPoint; exporting, embedthumb: boolean): string; +function FlameToXML(const cp1: TControlPoint; exporting, embedthumb: boolean): String; var t, i{, j}, pos: integer; FileList: TStringList; x, y: double; parameters: string; - str, buf, xdata: string; + curves, str, buf, xdata: string; begin FileList := TStringList.create; x := cp1.center[0]; @@ -1840,7 +1854,29 @@ function FlameToXML(const cp1: TControlPoint; exporting, embedthumb: boolean): s if (i = cp1.used_plugins.Count-1) then break; str := str + ' '; end; - parameters := parameters + format('plugins="%s" ', [str]); + parameters := parameters + format('plugins="%s" new_linear="1" ', [str]); + + for i := 0 to 3 do + begin + curves := curves + FloatToStr(cp1.curvePoints[i][0].x) + ' '; + curves := curves + FloatToStr(cp1.curvePoints[i][0].y) + ' '; + curves := curves + FloatToStr(cp1.curveWeights[i][0]) + ' '; + + curves := curves + FloatToStr(cp1.curvePoints[i][1].x) + ' '; + curves := curves + FloatToStr(cp1.curvePoints[i][1].y) + ' '; + curves := curves + FloatToStr(cp1.curveWeights[i][1]) + ' '; + + curves := curves + FloatToStr(cp1.curvePoints[i][2].x) + ' '; + curves := curves + FloatToStr(cp1.curvePoints[i][2].y) + ' '; + curves := curves + FloatToStr(cp1.curveWeights[i][2]) + ' '; + + curves := curves + FloatToStr(cp1.curvePoints[i][3].x) + ' '; + curves := curves + FloatToStr(cp1.curvePoints[i][3].y) + ' '; + curves := curves + FloatToStr(cp1.curveWeights[i][3]) + ' '; + end; + + curves := trim(curves); + parameters := parameters + format('curves="%s" ', [curves]); FileList.Add(''); { Write transform parameters } @@ -1938,8 +1974,10 @@ function TMainForm.SaveXMLFlame(const cp1: TControlPoint; title, filename: strin { Saves Flame parameters to end of file } var Tag: string; - IFile: TextFile; + IFile: File; FileList: TStringList; + RB: RawByteString; + i, p: integer; bakname: string; begin @@ -2009,16 +2047,15 @@ function TMainForm.SaveXMLFlame(const cp1: TControlPoint; title, filename: strin else begin // New file ... easy - AssignFile(IFile, filename); - ReWrite(IFile); - Writeln(IFile, ''); - Write(IFile, FlameToXML(cp1, false, true)); - Writeln(IFile, ''); - CloseFile(IFile); + FileList := TStringList.Create; + FileList.Text := '' + #$0D#$0A + + FlameToXML(cp1, false, true) + #$0D#$0A + ''; + FileList.SaveToFile(filename, TEncoding.UTF8); + FileList.Destroy; end; except begin - Application.MessageBox(PAnsiChar(Format(TextByKey('common-genericsavefailure'), [FileName])), 'Apophysis', 16); + Application.MessageBox(PChar(Format(TextByKey('common-genericsavefailure'), [FileName])), 'Apophysis', 16); Result := False; end; end; @@ -2044,7 +2081,7 @@ function TMainForm.SaveGradient(Gradient, Title, FileName: string): boolean; CloseFile(IFile); except on EInOutError do begin - Application.MessageBox(PAnsiChar(Format(TextByKey('common-genericsavefailure'), [FileName])), 'Apophysis', 16); + Application.MessageBox(PChar(Format(TextByKey('common-genericsavefailure'), [FileName])), 'Apophysis', 16); Result := False; end; end; @@ -2235,7 +2272,7 @@ procedure TMainForm.HandleThreadCompletion(var Message: TMessage); FViewImage := Renderer.GetTransparentImage; - if FViewImage <> nil then begin + if (FViewImage <> nil) and (FViewImage.Width > 0) then begin FViewScale := FViewImage.Width / Image.Width; FViewPos.X := FViewScale/oldscale * (FViewPos.X - FViewOldPos.X); @@ -2300,7 +2337,8 @@ procedure TMainForm.DrawPreview; cp.sample_density := 1; cp.spatial_oversample := 1; cp.spatial_filter_radius := 1; - + + Render.NrThreads := NrTreads; Render.SetCP(cp); Render.Render; BM.Assign(Render.GetImage); @@ -2312,6 +2350,7 @@ procedure TMainForm.DrawFlame; GlobalMemoryInfo: TMemoryStatus; // holds the global memory status information RenderCP: TControlPoint; Mem, ApproxMem: cardinal; + bs: integer; begin RedrawTimer.Enabled := False; if Assigned(Renderer) then begin @@ -2350,11 +2389,14 @@ procedure TMainForm.DrawFlame; GlobalMemoryStatus(GlobalMemoryInfo); Mem := GlobalMemoryInfo.dwAvailPhys; + if (singleBuffer) then bs := 16 + else bs := 32; + // if Output.Lines.Count >= 1000 then Output.Lines.Clear; Trace1('--- Previewing "' + RenderCP.name + '" ---'); Trace1(Format(' Available memory: %f Mb', [Mem / (1024*1024)])); ApproxMem := int64(RenderCp.Width) * int64(RenderCp.Height) {* sqr(Oversample)} - * (SizeOfBucket[InternalBitsPerSample] + 4 + 4); // +4 for temp image(s)...? + * (bs + 4 + 4); // +4 for temp image(s)...? assert(MainPreviewScale <> 0); if ApproxMem * sqr(MainPreviewScale) < Mem then begin if ExtendMainPreview then begin @@ -2377,6 +2419,7 @@ procedure TMainForm.DrawFlame; if TraceLevel > 0 then Renderer.Output := TraceForm.MainTrace.Lines; Renderer.OnProgress := OnProgress; Renderer.SetCP(RenderCP); + Renderer.NrThreads := FNrThreads; Trace2('Starting RenderThread #' + inttostr(Renderer.ThreadID)); Renderer.Resume; @@ -2430,8 +2473,8 @@ procedure TMainForm.RandomBatch; inc(MainSeed); RandSeed := MainSeed; try - AssignFile(F, AppPath + randFilename); - OpenFile := AppPath + randFilename; + AssignFile(F, GetEnvVarValue('APPDATA') + '\' + randFilename); + OpenFile := GetEnvVarValue('APPDATA') + '\' + randFilename; ReWrite(F); WriteLn(F, ''); for i := 0 to BatchSize - 1 do @@ -2457,9 +2500,9 @@ procedure TMainForm.RandomBatch; Write(F, ''); CloseFile(F); except - on EInOutError do Application.MessageBox(PAnsiChar(TextByKey('main-status-batcherror')), PChar('Apophysis'), 16); + on EInOutError do Application.MessageBox(PChar(TextByKey('main-status-batcherror')), PChar('Apophysis'), 16); end; - RandFile := AppPath + randFilename; + RandFile := GetEnvVarValue('APPDATA') + '\' + randFilename; MainCp.name := ''; end; @@ -2497,7 +2540,7 @@ function LoadXMLFlameText(filename, name: string) : string; p := Pos(' 0) then begin - MainForm.ListXMLScanner.LoadFromBuffer(PCHAR(FileStrings[i])); + MainForm.ListXMLScanner.LoadFromBuffer(TCharType(TStringType(FileStrings[i]))); MainForm.ListXMLScanner.Execute; if pname <> '' then begin @@ -2576,6 +2619,15 @@ function ScanVariations(name:string):boolean; exit; end; end; + for i := 0 to MainForm.SubstSource.Count - 1 do + begin + vname := MainForm.SubstSource[i]; + if (vname = name) then + begin + Result := true; + exit; + end; + end; Result := false; end; function ScanVariables(name:string):boolean; @@ -2591,6 +2643,14 @@ function ScanVariables(name:string):boolean; exit; end; end; + for i := 0 to MainForm.SubstSource.Count - 1 do + begin + if (MainForm.SubstSource[i] = name) then + begin + Result := true; + exit; + end; + end; Result := false; end; @@ -2598,7 +2658,10 @@ procedure TMainForm.mnuOpenClick(Sender: TObject); var fn:string; begin +{$ifdef DisableScripting} +{$else} ScriptEditor.Stopped := True; +{$endif} OpenDialog.Filter := TextByKey('common-filter-flamefiles') + '|*.flame;*.xml|' + TextByKey('common-filter-allfiles') + '|*.*'; OpenDialog.InitialDir := ParamFolder; OpenDialog.FileName := ''; @@ -2689,7 +2752,8 @@ procedure TMainForm.mnuItemDeleteClick(Sender: TObject); ListView1.Items.Delete(ListView1.Selected.Index); Application.ProcessMessages; ListView1.Selected := ListView1.ItemFocused; - RebuildListView; + //RebuildListView; + ListXML(OpenFile, ListView1.ItemIndex); end; end; //end; @@ -2735,11 +2799,14 @@ procedure TMainForm.mnuRWeightsClick(Sender: TObject); procedure TMainForm.mnuRandomBatchClick(Sender: TObject); begin +{$ifdef DisableScripting} +{$else} ScriptEditor.Stopped := True; +{$endif} inc(MainSeed); RandSeed := MainSeed; RandomBatch; - OpenFile := AppPath + randFilename; + OpenFile := GetEnvVarValue('APPDATA') + '\' + randFilename; OpenFileType := ftXML; MainForm.Caption := AppVersionString + ' - ' + TextByKey('main-common-randombatch'); ListXML(OpenFile, 1); @@ -2899,7 +2966,10 @@ procedure TMainForm.mnuEditorClick(Sender: TObject); procedure TMainForm.mnuExitClick(Sender: TObject); begin +{$ifdef DisableScripting} +{$else} ScriptEditor.Stopped := True; +{$endif} Close; end; @@ -2993,17 +3063,26 @@ procedure TMainForm.DisplayHint(Sender: TObject); procedure TMainForm.MainFileClick(Sender: TObject); begin +{$ifdef DisableScripting} +{$else} ScriptEditor.Stopped := True; +{$endif} end; procedure TMainForm.MainViewClick(Sender: TObject); begin +{$ifdef DisableScripting} +{$else} ScriptEditor.Stopped := True; +{$endif} end; procedure TMainForm.MainToolsClick(Sender: TObject); begin +{$ifdef DisableScripting} +{$else} ScriptEditor.Stopped := True; +{$endif} end; procedure TMainForm.MainHelpClick(Sender: TObject); @@ -3011,28 +3090,33 @@ procedure TMainForm.MainHelpClick(Sender: TObject); end; { ********************************* Form ************************************ } - - procedure TMainForm.FavoriteClick(Sender: TObject); var i: integer; s: string; begin +{$ifdef DisableScripting} +{$else} i := TMenuItem(Sender).Tag; Script := favorites[i]; ScriptEditor.Editor.Lines.LoadFromFile(Script); + s := ExtractFileName(Script); s := Copy(s, 0, length(s) - Length(ExtractFileExt(s))); mnuRun.Caption := Format(TextByKey('main-menu-script-run2'), [s]);//'Run "' + s + '"'; btnRunScript.Hint := Format(TextByKey('main-menu-script-run2'), [s]);//'Run Script (F8)|Runs the ' + s + ' script.'; //ScriptEditor.Caption := s; ScriptEditor.RunScript; + +{$endif} end; procedure TMainForm.ScriptItemClick(Sender: TObject); var s: string; begin +{$ifdef DisableScripting} +{$else} Script := ExtractFilePath(Application.ExeName) + scriptPath + '\' + TMenuItem(Sender).Hint + '.asc'; ScriptEditor.Editor.Lines.LoadFromFile(Script); s := ExtractFileName(Script); @@ -3041,6 +3125,7 @@ procedure TMainForm.ScriptItemClick(Sender: TObject); btnRunScript.Hint := Format(TextByKey('main-menu-script-run2'), [s]);//'Run Script (F8)|Runs the ' + s + ' script.'; //ScriptEditor.Caption := s; ScriptEditor.RunScript; +{$endif} end; procedure TMainForm.GetScripts; @@ -3061,6 +3146,8 @@ procedure TMainForm.GetScripts; NewItem := mnuScript.Find(TextByKey('main-menu-script-more')); if (NewItem <> nil) then mnuScript.Remove(NewItem); + {$ifdef DisableScripting} + {$else} if FileExists(ExtractFilePath(Application.ExeName) + scriptFavsFilename) then begin Favorites.LoadFromFile(AppPath + scriptFavsFilename); if Trim(Favorites.Text) <> '' then begin @@ -3133,20 +3220,56 @@ procedure TMainForm.GetScripts; FindClose(searchResult); mnuScript.Add(NewItem); end; + + {$endif} end; procedure TMainForm.FormCreate(Sender: TObject); var dte: string; + cmdl : TCommandLine; begin - KnownPlugins := TList.Create; + //KnownPlugins := TList.Create; + + FNrThreads := 1; ApophysisSVN:=APP_VERSION; AppVersionString:=APP_NAME+' '+APP_VERSION; - + + SubstSource := TStringList.Create; + SubstTarget := TStringList.Create; + + CreateSubstMap; + TbBreakWidth := 802; + + {$ifdef DisableScripting} + mnuScript.Visible := false; + {btnRunScript.Visible := false; + btnStopScript.Visible := false; + ToolButton17.Visible := false; + ToolButton18.Visible := false;} + + ToolBar.Perform(CM_CONTROLCHANGE, WPARAM(btnRunScript), 0); + ToolBar.Perform(CM_CONTROLCHANGE, WPARAM(btnStopScript), 0); + ToolBar.Perform(CM_CONTROLCHANGE, WPARAM(ToolButton17), 0); + ToolBar.Perform(CM_CONTROLCHANGE, WPARAM(ToolButton18), 0); + TbBreakWidth := TbBreakWidth - (3 * 26 + 1 * 8); + {$endif} + + ListXmlScanner := TEasyXmlScanner.Create(nil); + XmlScanner := TXmlScanner.Create(nil); + + MainForm.ListXmlScanner.Normalize := True; + MainForm.ListXmlScanner.OnStartTag := ListXmlScannerStartTag; + + MainForm.XmlScanner.Normalize := False; + MainForm.XmlScanner.OnContent := XmlScannerContent; + MainForm.XmlScanner.OnEmptyTag := XMLScannerEmptyTag; + MainForm.XmlScanner.OnEndTag := XmlScannerEndTag; + MainForm.XmlScanner.OnStartTag := XMLScannerStartTag; + ReadSettings; - //Temporary: force all users have 32 bit integer set as IBD InternalBitsPerSample := 0; renderBitsPerSample := 0; @@ -3160,8 +3283,13 @@ procedure TMainForm.FormCreate(Sender: TObject); AvailableLanguages.Add(''); ListLanguages; + C_SyncDllPlugins; + + cmdl := TCommandLine.Create; + cmdl.Load; + if (NXFORMS > 100) then AppVersionString := AppVersionString + ' (' + TextByKey('main-common-title-t500') + ')' - else if (NXFORMS < 100) then AppVersionString := AppVersionString + ' (' + TextByKey('main-common-title-lite') + ')'; + else if (NXFORMS < 100) or (cmdl.Lite) then AppVersionString := AppVersionString + ' (' + TextByKey('main-common-title-lite') + ')'; SplashWindow.SetInfo(TextByKey('splash-loadingui')); LockListChangeUpdate := false; @@ -3172,19 +3300,7 @@ procedure TMainForm.FormCreate(Sender: TObject); Caption := AppVersionString + APP_BUILD; mnuExportFLame.Enabled := FileExists(flam3Path); - mnuExportChaotica.Enabled := FileExists(chaoticaPath); -(* -{$IFDEF DEBUG} - // Enable raw mode (default mode uses stack frames which aren't always generated by the compiler) - Include(JclStackTrackingOptions, stRawMode); - // Disable stack tracking in dynamically loaded modules (it makes stack tracking code a bit faster) - Include(JclStackTrackingOptions, stStaticModuleList); - - // Initialize Exception tracking - JclStartExceptionTracking; - Application.OnException := AppException; -{$ENDIF} -*) + mnuExportChaotica.Enabled := FileExists(chaoticaPath + '\32bit\chaotica.exe'); FMouseMoveState := msDrag; LimitVibrancy := False; @@ -3196,7 +3312,6 @@ procedure TMainForm.FormCreate(Sender: TObject); ParseCp := TControlPoint.create; OpenFileType := ftXML; Application.OnHint := DisplayHint; - Application.OnHelp := ApplicationOnHelp; AppPath := ExtractFilePath(Application.ExeName); CanDrawOnResize := False; @@ -3208,16 +3323,13 @@ procedure TMainForm.FormCreate(Sender: TObject); RandomDate := Dte; mnuExit.ShortCut := TextToShortCut('Alt+F4'); - //if VariationOptions = 0 then VariationOptions := 16383; // it shouldn't hapen but just in case; - //UnpackVariations(VariationOptions); - SplashWindow.SetInfo(TextByKey('splash-loadingplugins')); FillVariantMenu; tbQualityBox.Text := FloatToStr(defSampleDensity); tbShowAlpha.Down := ShowTransparency; DrawSelection := true; - FViewScale := 1; // prevent divide by zero (?) + FViewScale := 1; ThumbnailSize := 128; UsedThumbnails := Thumbnails; if (UseSmallThumbnails) then begin @@ -3228,20 +3340,20 @@ procedure TMainForm.FormCreate(Sender: TObject); LoadThumbnailPlaceholder(ThumbnailSize); ListView1.LargeImages := UsedThumbnails; - //ListView1.SmallImages := UsedThumbnails; ListBackPanel.Width := ThumbnailSize + 90; Splitter.Left := ListBackPanel.Width; - if NXFORMS >= 100 then begin + if not cmdl.Lite then begin if ClassicListMode = true then btnViewListClick(nil) else btnViewIconsClick(nil); end else begin ListView1.ViewStyle := vsReport; - btnViewList.Visible := false; - btnViewIcons.Visible := false; - ToolButton9.Visible := false; + ToolBar.Perform(CM_CONTROLCHANGE, WPARAM(btnViewList), 0); + ToolBar.Perform(CM_CONTROLCHANGE, WPARAM(btnViewIcons), 0); + ToolBar.Perform(CM_CONTROLCHANGE, WPARAM(ToolButton9), 0); + TbBreakWidth := TbBreakWidth - (2 * 26 + 1 * 8); end; end; @@ -3258,10 +3370,6 @@ procedure TMainForm.FormShow(Sender: TObject); fn, flameXML : string; openScript : string; begin - EnumPlugins := true; - PluginMonitor.Enumerate; - EnumPlugins := false; - tbGuides.Down := EnableGuides; DoNotAskAboutChange := true; { Read position from registry } @@ -3322,8 +3430,8 @@ procedure TMainForm.FormShow(Sender: TObject); GetCMap(cmap_index, 1, maincp.cmap); DefaultPalette := maincp.cmap; end; - if FileExists(AppPath + randFilename) then - DeleteFile(AppPath + randFilename); + if FileExists(GetEnvVarValue('APPDATA') + '\' + randFilename) then + DeleteFile(GetEnvVarValue('APPDATA') + '\' + randFilename); cmdl := TCommandLine.Create; cmdl.Load; @@ -3354,7 +3462,7 @@ procedure TMainForm.FormShow(Sender: TObject); RandomBatch; if APP_BUILD = '' then MainForm.Caption := AppVersionString + ' - ' + TextByKey('main-common-randombatch') else MainForm.Caption := AppVersionString + ' ' + APP_BUILD + ' - ' + TextByKey('main-common-randombatch'); - OpenFile := AppPath + randFilename; + OpenFile := GetEnvVarValue('APPDATA') + '\' + randFilename; ListXML(OpenFile, 1); OpenFileType := ftXML; if batchsize = 1 then DrawFlame; @@ -3371,7 +3479,7 @@ procedure TMainForm.FormShow(Sender: TObject); RandomBatch; if APP_BUILD = '' then MainForm.Caption := AppVersionString + ' - ' + TextByKey('main-common-randombatch') else MainForm.Caption := AppVersionString + ' ' + APP_BUILD + ' - ' + TextByKey('main-common-randombatch'); - OpenFile := AppPath + randFilename; + OpenFile := GetEnvVarValue('APPDATA') + '\' + randFilename; ListXML(OpenFile, 1); OpenFileType := ftXML; if batchsize = 1 then DrawFlame; @@ -3421,7 +3529,10 @@ procedure TMainForm.FormShow(Sender: TObject); fn:=cmdl.TemplateFile; flameXML := LoadXMLFlameText(fn, cmdl.TemplateName); UpdateUndo; - ScriptEditor.Stopped := True; +{$ifdef DisableScripting} +{$else} + ScriptEditor.Stopped := True; +{$endif} StopThread; InvokeLoadXML(flameXML); Transforms := MainCp.TrianglesFromCP(MainTriangles); @@ -3435,7 +3546,8 @@ procedure TMainForm.FormShow(Sender: TObject); end; // .. and run autoexec.asc - +{$ifdef DisableScripting} +{$else} SplashWindow.SetInfo(TextByKey('splash-execstartupscript')); if (FileExists(AppPath + 'autoexec.asc')) then begin ScriptEditor.LoadRunAndClear(AppPath + 'autoexec.asc'); @@ -3447,7 +3559,9 @@ procedure TMainForm.FormShow(Sender: TObject); ScriptEditor.LoadScriptFile(openScript); ScriptEditor.Show; end; +{$endif} + //FNrThreads := Nrtreads; SplashWindow.Hide; SplashWindow.Free; @@ -3495,13 +3609,16 @@ procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction); Registry: TRegistry; begin if ConfirmExit and (UndoIndex <> 0) then - if Application.MessageBox(PAnsiChar(TextByKey('common-confirmexit')), 'Apophysis', MB_ICONWARNING or MB_YESNO) <> IDYES then + if Application.MessageBox(PChar(TextByKey('common-confirmexit')), 'Apophysis', MB_ICONWARNING or MB_YESNO) <> IDYES then begin Action := caNone; exit; end; +{$ifdef DisableScripting} +{$else} ScriptEditor.Stopped := True; +{$endif} HtmlHelp(0, nil, HH_CLOSE_ALL, 0); { To capture secondary window positions } if EditForm.visible then EditForm.Close; @@ -3509,7 +3626,11 @@ procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction); if GradientBrowser.visible then GradientBrowser.close; if MutateForm.visible then MutateForm.Close; // if GradientForm.visible then GradientForm.Close; +{$ifdef DisableScripting} +{$else} if ScriptEditor.visible then ScriptEditor.Close; +{$endif} + { Stop the render thread } if RenderForm.Visible then RenderForm.Close; if assigned(Renderer) then Renderer.Terminate; @@ -3532,8 +3653,10 @@ procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction); end; Application.ProcessMessages; CanDrawOnResize := False; - if FileExists(randFilename) then DeleteFile(randFilename); - if FileExists(undoFilename) then DeleteFile(undoFilename); + if FileExists(GetEnvVarValue('APPDATA') + '\' + randFilename) then + DeleteFile(GetEnvVarValue('APPDATA') + '\' + randFilename); + if FileExists(GetEnvVarValue('APPDATA') + '\' + undoFilename) then + DeleteFile(GetEnvVarValue('APPDATA') + '\' + undoFilename); SaveSettings; end; @@ -3571,7 +3694,10 @@ procedure TMainForm.FormKeyPress(Sender: TObject; var Key: Char); end; DrawImageView; end; +{$ifdef DisableScripting} +{$else} ScriptEditor.Stopped := True; +{$endif} end; { ****************************** Misc controls ****************************** } @@ -3617,7 +3743,7 @@ procedure TMainForm.LoadXMLFlame(filename, name: string); p := Pos(' 0) then begin - MainForm.ListXMLScanner.LoadFromBuffer(PCHAR(FileStrings[i])); + MainForm.ListXMLScanner.LoadFromBuffer(TCharType(TStringType(FileStrings[i]))); MainForm.ListXMLScanner.Execute; if pname <> '' then begin @@ -3643,10 +3769,12 @@ procedure TMainForm.LoadXMLFlame(filename, name: string); ParamStrings.Add(FileStrings[i]); until pos('', Lowercase(FileStrings[i])) <> 0; - ScriptEditor.Stopped := True; - px:=PCHAR(PAramStrings.Text); +{$ifdef DisableScripting} +{$else} + ScriptEditor.Stopped := True; +{$endif} StopThread; - ParseXML(MainCp,px, true); + ParseXML(MainCp,PAramStrings.Text, true); mnuSaveUndo.Enabled := false; mnuUndo.Enabled := False; @@ -3666,7 +3794,8 @@ procedure TMainForm.LoadXMLFlame(filename, name: string); UndoIndex := 0; UndoMax := 0; - if fileExists(AppPath + undoFilename) then DeleteFile(AppPath + undoFilename); + if fileExists(GetEnvVarValue('APPDATA') + '\' + undoFilename) then + DeleteFile(GetEnvVarValue('APPDATA') + '\' + undoFilename); Statusbar.Panels[3].Text := Maincp.name; RedrawTimer.Enabled := True; Application.ProcessMessages; @@ -3735,7 +3864,10 @@ procedure TMainForm.ListViewChange(Sender: TObject; Item: TListItem; begin SavedPal := false; - ScriptEditor.Stopped := True; +{$ifdef DisableScripting} +{$else} + ScriptEditor.Stopped := True; +{$endif} FStrings := TStringList.Create; IFSStrings := TStringList.Create; Tokens := TStringList.Create; @@ -3823,7 +3955,8 @@ procedure TMainForm.ListViewChange(Sender: TObject; Item: TListItem; if SavedPal then maincp.cmap := Palette; UndoIndex := 0; UndoMax := 0; - if fileExists(AppPath + undoFilename) then DeleteFile(AppPath + undoFilename); + if fileExists(GetEnvVarValue('APPDATA') + '\' + undoFilename) then + DeleteFile(GetEnvVarValue('APPDATA') + '\' + undoFilename); maincp.name := ListView.Selected.Caption; Statusbar.Panels[3].Text := maincp.name; RedrawTimer.Enabled := True; @@ -3847,6 +3980,8 @@ procedure TMainForm.UpdateWindows; if AdjustForm.visible then AdjustForm.UpdateDisplay; if EditForm.visible then EditForm.UpdateDisplay; if MutateForm.visible then MutateForm.UpdateDisplay; + if CurvesForm.Visible then CurvesForm.SetCp(MainCp); + end; procedure TMainForm.LoadUndoFlame(index: integer; filename: string); @@ -3859,7 +3994,10 @@ procedure TMainForm.LoadUndoFlame(index: integer; filename: string); s: string; Palette: TColorMap; begin +{$ifdef DisableScripting} +{$else} ScriptEditor.Stopped := True; +{$endif} FStrings := TStringList.Create; IFSStrings := TStringList.Create; Tokens := TStringList.Create; @@ -4190,6 +4328,11 @@ procedure TMainForm.mnuToolbarClick(Sender: TObject); mnuToolbar.Checked := Toolbar.visible; end; +procedure TMainForm.mnuTraceClick(Sender: TObject); +begin + TraceForm.Show; +end; + procedure TMainForm.mnuStatusBarClick(Sender: TObject); begin Statusbar.Visible := not Statusbar.Visible; @@ -4206,10 +4349,11 @@ procedure TMainForm.mnuFileContentsClick(Sender: TObject); procedure TMainForm.Undo; begin if UndoIndex = UndoMax then - SaveFlame(maincp, Format('%.4d-', [UndoIndex]) + maincp.name, AppPath + undoFilename); + SaveFlame(maincp, Format('%.4d-', [UndoIndex]) + maincp.name, + GetEnvVarValue('APPDATA') + '\' + undoFilename); StopThread; Dec(UndoIndex); - LoadUndoFlame(UndoIndex, AppPath + undoFilename); + LoadUndoFlame(UndoIndex, GetEnvVarValue('APPDATA') + '\' + undoFilename); mnuRedo.Enabled := True; mnuPopRedo.Enabled := True; btnRedo.Enabled := True; @@ -4239,7 +4383,7 @@ procedure TMainForm.Redo; assert(UndoIndex <= UndoMax, 'Undo list index out of range!'); - LoadUndoFlame(UndoIndex, AppPath + undoFilename); + LoadUndoFlame(UndoIndex, GetEnvVarValue('APPDATA') + '\' + undoFilename); mnuUndo.Enabled := True; mnuPopUndo.Enabled := True; btnUndo.Enabled := True; @@ -4294,7 +4438,7 @@ procedure TMainForm.mnuRenderClick(Sender: TObject); NewRender := True; if Assigned(RenderForm.Renderer) then - if Application.MessageBox(PAnsiChar(TextByKey('render-status-confirmstop')), 'Apophysis', 36) = ID_NO then + if Application.MessageBox(PChar(TextByKey('render-status-confirmstop')), 'Apophysis', 36) = ID_NO then NewRender := false; if NewRender then @@ -4334,7 +4478,7 @@ procedure TMainForm.mnuRenderAllClick(Sender: TObject); NewRender := True; if Assigned(RenderForm.Renderer) then - if Application.MessageBox(PAnsiChar(TextByKey('render-status-confirmstop')), 'Apophysis', 36) = ID_NO then + if Application.MessageBox(PChar(TextByKey('render-status-confirmstop')), 'Apophysis', 36) = ID_NO then NewRender := false; if NewRender then @@ -4430,7 +4574,7 @@ procedure TMainForm.mnuOpenGradientClick(Sender: TObject); procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean); begin if Assigned(RenderForm.Renderer) then - if Application.MessageBox(PAnsiChar(TextByKey('render-status-confirmstop')), 'Apophysis', 36) = ID_NO then + if Application.MessageBox(PChar(TextByKey('render-status-confirmstop')), 'Apophysis', 36) = ID_NO then CanClose := False; AboutToExit := CanClose; @@ -4475,27 +4619,42 @@ procedure TMainForm.mnuRandomizeColorValuesClick(Sender: TObject); procedure TMainForm.mnuEditScriptClick(Sender: TObject); begin +{$ifdef DisableScripting} +{$else} ScriptEditor.Show; +{$endif} end; procedure TMainForm.btnRunClick(Sender: TObject); begin + {$ifdef DisableScripting} +{$else} ScriptEditor.RunScript; +{$endif} end; procedure TMainForm.mnuRunClick(Sender: TObject); begin +{$ifdef DisableScripting} +{$else} ScriptEditor.RunScript; +{$endif} end; procedure TMainForm.mnuOpenScriptClick(Sender: TObject); begin +{$ifdef DisableScripting} +{$else} ScriptEditor.OpenScript; +{$endif} end; procedure TMainForm.mnuStopClick(Sender: TObject); begin +{$ifdef DisableScripting} +{$else} ScriptEditor.Stopped := True; +{$endif} end; procedure TMainForm.mnuImportGimpClick(Sender: TObject); @@ -4532,6 +4691,8 @@ procedure TMainForm.mnuManageFavoritesClick(Sender: TObject); i: integer; s: string; begin +{$ifdef DisableScripting} +{$else} if FavoritesForm.ShowModal = mrOK then begin if favorites.count <> 0 then @@ -4548,6 +4709,7 @@ procedure TMainForm.mnuManageFavoritesClick(Sender: TObject); end; GetScripts; end; +{$endif} end; procedure TMainForm.DisableFavorites; @@ -4622,7 +4784,7 @@ procedure TMainForm.ApplicationEventsActivate(Sender: TObject); end; end; -procedure TMainForm.ParseXML(var cp1: TControlPoint; const params: PCHAR; const ignoreErrors : boolean); +procedure TMainForm.ParseXML(var cp1: TControlPoint; const params: string; const ignoreErrors : boolean); var i: integer; temp: string; h, s, v: real; @@ -4645,7 +4807,7 @@ procedure TMainForm.ParseXML(var cp1: TControlPoint; const params: PCHAR; const //LoadCpFromXmlCompatible(params, ParseCP, temp); - XMLScanner.LoadFromBuffer(params); + XMLScanner.LoadFromBuffer(TCharType(TStringType(params))); XMLScanner.Execute; cp1.copy(ParseCp); @@ -4691,7 +4853,10 @@ procedure TMainForm.mnuPasteClick(Sender: TObject); begin if Clipboard.HasFormat(CF_TEXT) then begin UpdateUndo; - ScriptEditor.Stopped := True; +{$ifdef DisableScripting} +{$else} + ScriptEditor.Stopped := True; +{$endif} StopThread; ParseXML(MainCP, PCHAR(Clipboard.AsText), false); AnnoyUser; @@ -4752,7 +4917,7 @@ procedure TMainForm.mnuExportFlameClick(Sender: TObject); begin if not FileExists(flam3Path) then begin - Application.MessageBox(PAnsiChar(TextByKey('main-status-noflam3')), 'Apophysis', 16); + Application.MessageBox(PChar(TextByKey('main-status-noflam3')), 'Apophysis', 16); exit; end; case ExportFileFormat of @@ -4876,7 +5041,7 @@ procedure ParseCompactColors(cp: TControlPoint; count: integer; in_data: string; for i := 1 to Length(in_data) do begin c := in_data[i]; - if c in ['0'..'9']+['A'..'F']+['a'..'f'] then data := data + c; + if CharInSet(c,['0'..'9']+['A'..'F']+['a'..'f']) then data := data + c; end; if alpha then len := count * 8 @@ -4896,24 +5061,24 @@ procedure ParseCompactColors(cp: TControlPoint; count: integer; in_data: string; procedure TMainForm.ListXmlScannerStartTag(Sender: TObject; TagName: string; Attributes: TAttrList); begin - pname := Attributes.value('name'); - ptime := Attributes.value('time'); + pname := String(Attributes.value(TStringType('name'))); + ptime := String(Attributes.value(TStringType('time'))); end; procedure TMainForm.XMLScannerStartTag(Sender: TObject; TagName: string; Attributes: TAttrList); var Tokens: TStringList; - v: string; - i : integer; + v: TStringType; + ParsePos, i : integer; begin Tokens := TStringList.Create; try if TagName='xformset' then // unused in this release... begin - v := Attributes.Value('enabled'); - if v <> '' then ParseCP.finalXformEnabled := (StrToInt(v) <> 0) + v := Attributes.Value(TStringType('enabled')); + if v <> '' then ParseCP.finalXformEnabled := (StrToInt(String(v)) <> 0) else ParseCP.finalXformEnabled := true; inc(activeXformSet); @@ -4922,71 +5087,97 @@ procedure TMainForm.XMLScannerStartTag(Sender: TObject; TagName: string; begin BeginParsing; - v := Attributes.value('name'); - if v <> '' then Parsecp.name := v else Parsecp.name := 'untitled'; + v := Attributes.value(TStringType('name')); + if v <> '' then Parsecp.name := String(v) else Parsecp.name := 'untitled'; v := Attributes.Value('time'); - if v <> '' then Parsecp.Time := StrToFloat(v); + if v <> '' then Parsecp.Time := StrToFloat(String(v)); v := Attributes.value('palette'); if v <> '' then - Parsecp.cmapindex := StrToInt(v) + Parsecp.cmapindex := StrToInt(String(v)) else Parsecp.cmapindex := -1; v := Attributes.value('gradient'); if v <> '' then - Parsecp.cmapindex := StrToInt(v) + Parsecp.cmapindex := StrToInt(String(v)) else Parsecp.cmapindex := -1; ParseCP.hue_rotation := 1; v := Attributes.value('hue'); - if v <> '' then Parsecp.hue_rotation := StrToFloat(v); + if v <> '' then Parsecp.hue_rotation := StrToFloat(String(v)); v := Attributes.Value('brightness'); - if v <> '' then Parsecp.Brightness := StrToFloat(v); + if v <> '' then Parsecp.Brightness := StrToFloat(String(v)); v := Attributes.Value('gamma'); - if v <> '' then Parsecp.gamma := StrToFloat(v); + if v <> '' then Parsecp.gamma := StrToFloat(String(v)); v := Attributes.Value('vibrancy'); - if v <> '' then Parsecp.vibrancy := StrToFloat(v); + if v <> '' then Parsecp.vibrancy := StrToFloat(String(v)); if (LimitVibrancy) and (Parsecp.vibrancy > 1) then Parsecp.vibrancy := 1; v := Attributes.Value('gamma_threshold'); - if v <> '' then Parsecp.gamma_threshold := StrToFloat(v) + if v <> '' then Parsecp.gamma_threshold := StrToFloat(String(v)) else Parsecp.gamma_threshold := 0; v := Attributes.Value('zoom'); - if v <> '' then Parsecp.zoom := StrToFloat(v); + if v <> '' then Parsecp.zoom := StrToFloat(String(v)); v := Attributes.Value('scale'); - if v <> '' then Parsecp.pixels_per_unit := StrToFloat(v); + if v <> '' then Parsecp.pixels_per_unit := StrToFloat(String(v)); v := Attributes.Value('rotate'); - if v <> '' then Parsecp.FAngle := -PI * StrToFloat(v)/180; + if v <> '' then Parsecp.FAngle := -PI * StrToFloat(String(v))/180; v := Attributes.Value('angle'); - if v <> '' then Parsecp.FAngle := StrToFloat(v); + if v <> '' then Parsecp.FAngle := StrToFloat(String(v)); // 3d v := Attributes.Value('cam_pitch'); - if v <> '' then Parsecp.cameraPitch := StrToFloat(v); + if v <> '' then Parsecp.cameraPitch := StrToFloat(String(v)); v := Attributes.Value('cam_yaw'); - if v <> '' then Parsecp.cameraYaw := StrToFloat(v); + if v <> '' then Parsecp.cameraYaw := StrToFloat(String(v)); v := Attributes.Value('cam_dist'); - if v <> '' then Parsecp.cameraPersp := 1/StrToFloat(v); + if v <> '' then Parsecp.cameraPersp := 1/StrToFloat(String(v)); v := Attributes.Value('cam_perspective'); - if v <> '' then Parsecp.cameraPersp := StrToFloat(v); + if v <> '' then Parsecp.cameraPersp := StrToFloat(String(v)); v := Attributes.Value('cam_zpos'); - if v <> '' then Parsecp.cameraZpos := StrToFloat(v); + if v <> '' then Parsecp.cameraZpos := StrToFloat(String(v)); v := Attributes.Value('cam_dof'); - if v <> '' then Parsecp.cameraDOF := abs(StrToFloat(v)); + if v <> '' then Parsecp.cameraDOF := abs(StrToFloat(String(v))); //density estimation v := Attributes.Value('estimator_radius'); - if v <> '' then Parsecp.estimator := StrToFloat(v); + if v <> '' then Parsecp.estimator := StrToFloat(String(v)); v := Attributes.Value('estimator_minimum'); - if v <> '' then Parsecp.estimator_min := StrToFloat(v); + if v <> '' then Parsecp.estimator_min := StrToFloat(String(v)); v := Attributes.Value('estimator_curve'); - if v <> '' then Parsecp.estimator_curve := StrToFloat(v); + if v <> '' then Parsecp.estimator_curve := StrToFloat(String(v)); v := Attributes.Value('enable_de'); if (v = '1') then Parsecp.enable_de := true; + v := Attributes.Value('new_linear'); + if (v = '1') then Parsecp.noLinearFix := true + else ParseCp.noLinearFix := false; + + v := Attributes.Value('curves'); + if (v <> '') then begin + GetTokens(String(v), tokens); + ParsePos := -1; + for i := 0 to 3 do + begin + Inc(ParsePos);ParseCp.curvePoints[i][0].x := StrToFloat(Tokens[ParsePos]); + Inc(ParsePos);ParseCp.curvePoints[i][0].y := StrToFloat(Tokens[ParsePos]); + Inc(ParsePos);ParseCp.curveWeights[i][0] := StrToFloat(Tokens[ParsePos]); + Inc(ParsePos);ParseCp.curvePoints[i][1].x := StrToFloat(Tokens[ParsePos]); + Inc(ParsePos);ParseCp.curvePoints[i][1].y := StrToFloat(Tokens[ParsePos]); + Inc(ParsePos);ParseCp.curveWeights[i][1] := StrToFloat(Tokens[ParsePos]); + Inc(ParsePos);ParseCp.curvePoints[i][2].x := StrToFloat(Tokens[ParsePos]); + Inc(ParsePos);ParseCp.curvePoints[i][2].y := StrToFloat(Tokens[ParsePos]); + Inc(ParsePos);ParseCp.curveWeights[i][2] := StrToFloat(Tokens[ParsePos]); + Inc(ParsePos);ParseCp.curvePoints[i][3].x := StrToFloat(Tokens[ParsePos]); + Inc(ParsePos);ParseCp.curvePoints[i][3].y := StrToFloat(Tokens[ParsePos]); + Inc(ParsePos);ParseCp.curveWeights[i][3] := StrToFloat(Tokens[ParsePos]); + end; + + end; + try v := Attributes.Value('center'); - GetTokens(v, tokens); + GetTokens(String(v), tokens); Parsecp.center[0] := StrToFloat(Tokens[0]); Parsecp.center[1] := StrToFloat(Tokens[1]); @@ -4996,14 +5187,14 @@ procedure TMainForm.XMLScannerStartTag(Sender: TObject; TagName: string; end; v := Attributes.Value('size'); - GetTokens(v, tokens); + GetTokens(String(v), tokens); Parsecp.width := StrToInt(Tokens[0]); Parsecp.height := StrToInt(Tokens[1]); try v := Attributes.Value('background'); - GetTokens(v, tokens); + GetTokens(String(v), tokens); Parsecp.background[0] := Floor(StrToFloat(Tokens[0]) * 255); Parsecp.background[1] := Floor(StrToFloat(Tokens[1]) * 255); @@ -5015,10 +5206,10 @@ procedure TMainForm.XMLScannerStartTag(Sender: TObject; TagName: string; end; v := Attributes.Value('soloxform'); - if v <> '' then Parsecp.soloXform := StrToInt(v); + if v <> '' then Parsecp.soloXform := StrToInt(String(v)); v := Attributes.Value('plugins'); - GetTokens(v, tokens); + GetTokens(String(v), tokens); if (tokens.Count > 0) then begin ParseCP.used_plugins.Clear; @@ -5027,27 +5218,95 @@ procedure TMainForm.XMLScannerStartTag(Sender: TObject; TagName: string; end; v := Attributes.Value('nick'); - if Trim(v) = '' then v := SheepNick; - Parsecp.Nick := v; + if Trim(String(v)) = '' then v := TStringType(SheepNick); + Parsecp.Nick := String(v); v := Attributes.Value('url'); - if Trim(v) = '' then v := SheepUrl; - Parsecp.URL := v; + if Trim(String(v)) = '' then v := TStringType(SheepUrl); + Parsecp.URL := String(v); end else if TagName='palette' then begin - XMLPaletteFormat := Attributes.Value('format'); - XMLPaletteCount := StrToIntDef(Attributes.Value('count'), 256); + XMLPaletteFormat := String(Attributes.Value('format')); + XMLPaletteCount := StrToIntDef(String(Attributes.Value('count')), 256); end; finally Tokens.free; end; end; +function flatten_val(Attributes: TAttrList): double; +var + vv: array of double; + vn: array of string; + i: integer; + s: string; + d: boolean; +begin + + SetLength(vv, 24); + SetLength(vn, 24); + + d := false; + + vn[0] := 'linear3D'; vn[1] := 'bubble'; + vn[2] := 'cylinder'; vn[3] := 'zblur'; + vn[4] := 'blur3D'; vn[5] := 'pre_ztranslate'; + vn[6] := 'pre_rotate_x'; vn[7] := 'pre_rotate_y'; + vn[8] := 'ztranslate'; vn[9] := 'zcone'; + vn[10] := 'post_rotate_x'; vn[11] := 'post_rotate_y'; + vn[12] := 'julia3D'; vn[13] := 'julia3Dz'; + vn[14] := 'curl3D_cz'; vn[15] := 'hemisphere'; + vn[16] := 'bwraps2'; vn[17] := 'bwraps'; + vn[18] := 'falloff2'; vn[19] := 'crop'; + vn[20] := 'pre_falloff2'; vn[21] := 'pre_crop'; + vn[22] := 'post_falloff2'; vn[23] := 'post_crop'; + + + for i := 0 to 23 do + begin + s := String(Attributes.Value(TStringType(vn[i]))); + if (s <> '') then vv[i] := StrToFloat(s) + else vv[i] := 0; + d := d or (vv[i] <> 0); + end; + + if (d) then Result := 0 + else Result := 1; + + SetLength(vv, 0); + SetLength(vn, 0); +end; +function linear_val(Attributes: TAttrList): double; +var + vv: array of double; + vn: array of string; + i: integer; + s: string; +begin + SetLength(vv, 2); + SetLength(vn, 2); + + Result := 0; + + vn[0] := 'linear3D'; + vn[1] := 'linear'; + for i := 0 to 1 do + begin + s := String(Attributes.Value(TStringType(vn[i]))); + if (s <> '') then vv[i] := StrToFloat(s) + else vv[i] := 0; + Result := Result + vv[i]; + end; + + SetLength(vv, 0); + SetLength(vn, 0); +end; + procedure TMainForm.XmlScannerContent(Sender: TObject; Content: String); begin if XMLPaletteCount <= 0 then begin //ShowMessage('ERROR: No colors in palette!'); - Application.MessageBox(PAnsiChar(TextByKey('common-invalidformat')), 'Apophysis', MB_ICONERROR); + Application.MessageBox(PChar(TextByKey('common-invalidformat')), 'Apophysis', MB_ICONERROR); exit; end; if XMLPaletteFormat = 'RGB' then @@ -5059,7 +5318,7 @@ procedure TMainForm.XmlScannerContent(Sender: TObject; Content: String); ParseCompactColors(ParseCP, XMLPaletteCount, Content); end else begin - Application.MessageBox(PAnsiChar(TextByKey('common-invalidformat')), 'Apophysis', MB_ICONERROR); + Application.MessageBox(PChar(TextByKey('common-invalidformat')), 'Apophysis', MB_ICONERROR); exit; end; Parsecp.cmapindex := -1; @@ -5072,46 +5331,46 @@ procedure TMainForm.XMLScannerEmptyTag(Sender: TObject; TagName: string; Attributes: TAttrList); var i: integer; - v: string; - d, floatcolor: double; + v, l, l3d: TStringType; + d, floatcolor, vl, vl3d: double; Tokens: TStringList; begin Tokens := TStringList.Create; try if (TagName = 'xform') or (TagName = 'finalxform') then - if {(TagName = 'finalxform') and} (FinalXformLoaded) then Application.MessageBox(PAnsiChar(TextByKey('common-invalidformat')), 'Apophysis', MB_ICONERROR) + if {(TagName = 'finalxform') and} (FinalXformLoaded) then Application.MessageBox(PChar(TextByKey('common-invalidformat')), 'Apophysis', MB_ICONERROR) else begin for i := 0 to Attributes.Count - 1 do begin - if not ScanVariations(attributes.Name(i)) and - not ScanVariables(attributes.Name(i)) then - CheckAttribute(Attributes.Name(i)); + if not ScanVariations(String(attributes.Name(i))) and + not ScanVariables(String(attributes.Name(i))) then + CheckAttribute(String(Attributes.Name(i))); end; if (TagName = 'finalxform') or (activeXformSet > 0) then FinalXformLoaded := true; with ParseCP.xform[nXform] do begin Clear; v := Attributes.Value('weight'); - if (v <> '') and (TagName = 'xform') then density := StrToFloat(v); + if (v <> '') and (TagName = 'xform') then density := StrToFloat(String(v)); if (TagName = 'finalxform') then begin v := Attributes.Value('enabled'); - if v <> '' then ParseCP.finalXformEnabled := (StrToInt(v) <> 0) + if v <> '' then ParseCP.finalXformEnabled := (StrToInt(String(v)) <> 0) else ParseCP.finalXformEnabled := true; end; if activexformset > 0 then density := 0; // tmp... v := Attributes.Value('color'); - if v <> '' then color := StrToFloat(v); + if v <> '' then color := StrToFloat(String(v)); v := Attributes.Value('var_color'); - if v <> '' then pluginColor := StrToFloat(v); + if v <> '' then pluginColor := StrToFloat(String(v)); v := Attributes.Value('symmetry'); - if v <> '' then symmetry := StrToFloat(v); + if v <> '' then symmetry := StrToFloat(String(v)); v := Attributes.Value('coefs'); - GetTokens(v, tokens); - if Tokens.Count < 6 then Application.MessageBox(PAnsiChar(TextByKey('common-invalidformat')), 'Apophysis', MB_ICONERROR); + GetTokens(String(v), tokens); + if Tokens.Count < 6 then Application.MessageBox(PChar(TextByKey('common-invalidformat')), 'Apophysis', MB_ICONERROR); c[0][0] := StrToFloat(Tokens[0]); c[0][1] := StrToFloat(Tokens[1]); c[1][0] := StrToFloat(Tokens[2]); @@ -5121,8 +5380,8 @@ procedure TMainForm.XMLScannerEmptyTag(Sender: TObject; TagName: string; v := Attributes.Value('post'); if v <> '' then begin - GetTokens(v, tokens); - if Tokens.Count < 6 then Application.MessageBox(PAnsiChar(TextByKey('common-invalidformat')), 'Apophysis', MB_ICONERROR); + GetTokens(String(v), tokens); + if Tokens.Count < 6 then Application.MessageBox(PChar(TextByKey('common-invalidformat')), 'Apophysis', MB_ICONERROR); p[0][0] := StrToFloat(Tokens[0]); p[0][1] := StrToFloat(Tokens[1]); p[1][0] := StrToFloat(Tokens[2]); @@ -5133,7 +5392,7 @@ procedure TMainForm.XMLScannerEmptyTag(Sender: TObject; TagName: string; v := Attributes.Value('chaos'); if v <> '' then begin - GetTokens(v, tokens); + GetTokens(String(v), tokens); for i := 0 to Tokens.Count-1 do modWeights[i] := Abs(StrToFloat(Tokens[i])); end; @@ -5142,17 +5401,17 @@ procedure TMainForm.XMLScannerEmptyTag(Sender: TObject; TagName: string; // for 2.09 flames compatibility v := Attributes.Value('opacity'); if v <> '' then begin - if StrToFloat(v) = 0.0 then begin + if StrToFloat(String(v)) = 0.0 then begin transOpacity := 0; end else begin - transOpacity := StrToFloat(v); + transOpacity := StrToFloat(String(v)); end; end; // 7x.9 name tag v := Attributes.Value('name'); if v <> '' then begin - TransformName := v; + TransformName := String(v); end; v := Attributes.Value('plotmode'); @@ -5162,43 +5421,63 @@ procedure TMainForm.XMLScannerEmptyTag(Sender: TObject; TagName: string; end; end; - for i := 0 to NRVAR - 1 do + // tricky: attempt to convert parameters to 15C+-format if necessary + if (ParseCp.noLinearFix) then + for i := 0 to 1 do + begin + SetVariation(i, 0); + v := TStringType(ReadWithSubst(Attributes, varnames(i))); + //v := Attributes.Value(AnsiString(varnames(i))); + if v <> '' then + SetVariation(i, StrToFloat(String(v))); + end + else begin + SetVariation(0, linear_val(Attributes)); + SetVariation(1, flatten_val(Attributes)); + end; + + // now parse the rest of the variations...as usual + for i := 2 to NRVAR - 1 do begin SetVariation(i, 0); - v := Attributes.Value(varnames(i)); + v := TStringType(ReadWithSubst(Attributes, varnames(i))); + //v := Attributes.Value(AnsiString(varnames(i))); if v <> '' then - SetVariation(i, StrToFloat(v)); + SetVariation(i, StrToFloat(String(v))); + end; + + // and the variables + for i := 0 to GetNrVariableNames - 1 do begin + v := TStringType(ReadWithSubst(Attributes, GetVariableNameAt(i))); + //v := Attributes.Value(AnsiString(GetVariableNameAt(i))); + if v <> '' then begin + {$ifndef VAR_STR} + d := StrToFloat(String(v)); + SetVariable(GetVariableNameAt(i), d); + {$else} + SetVariableStr(GetVariableNameAt(i), String(v)); + {$endif} + end; end; + // legacy variation/variable notation v := Attributes.Value('var1'); if v <> '' then begin for i := 0 to NRVAR - 1 do SetVariation(i, 0); - SetVariation(StrToInt(v), 1); + SetVariation(StrToInt(String(v)), 1); end; v := Attributes.Value('var'); if v <> '' then begin for i := 0 to NRVAR - 1 do SetVariation(i, 0); - GetTokens(v, tokens); - if Tokens.Count > NRVAR then Application.MessageBox(PAnsiChar(TextByKey('common-invalidformat')), 'Apophysis', MB_ICONERROR); + GetTokens(String(v), tokens); + if Tokens.Count > NRVAR then Application.MessageBox(PChar(TextByKey('common-invalidformat')), 'Apophysis', MB_ICONERROR); for i := 0 to Tokens.Count - 1 do SetVariation(i, StrToFloat(Tokens[i])); end; - - for i := 0 to GetNrVariableNames - 1 do begin - v := Attributes.Value(GetVariableNameAt(i)); - if v <> '' then begin -{$ifndef VAR_STR} - d := StrToFloat(v); - SetVariable(GetVariableNameAt(i), d); -{$else} - SetVariableStr(GetVariableNameAt(i), v); -{$endif} - end; - end; end; Inc(nXform); end; @@ -5208,9 +5487,9 @@ procedure TMainForm.XMLScannerEmptyTag(Sender: TObject; TagName: string; //if Parsecp.cmapindex = -2 then Parsecp.cmapindex := -1; - i := StrToInt(Attributes.value('index')); + i := StrToInt(String(Attributes.value('index'))); v := Attributes.value('rgb'); - GetTokens(v, tokens); + GetTokens(String(v), tokens); floatcolor := StrToFloat(Tokens[0]); Parsecp.cmap[i][0] := round(floatcolor); floatcolor := StrToFloat(Tokens[1]); @@ -5220,17 +5499,18 @@ procedure TMainForm.XMLScannerEmptyTag(Sender: TObject; TagName: string; end; if TagName = 'colors' then begin - ParseCompactcolors(Parsecp, StrToInt(Attributes.value('count')), Attributes.value('data')); + ParseCompactcolors(Parsecp, StrToInt(String(Attributes.value('count'))), + String(Attributes.value('data'))); Parsecp.cmapindex := -1; end; if TagName = 'symmetry' then begin - i := StrToInt(Attributes.value('kind')); + i := StrToInt(String(Attributes.value('kind'))); Parsecp.symmetry := i; end; if TagName = 'xdata' then begin - Parsecp.xdata := Parsecp.xdata + Attributes.value('content'); + Parsecp.xdata := Parsecp.xdata + String(Attributes.value('content')); end; finally Tokens.free; @@ -5914,23 +6194,6 @@ procedure TMainForm.ImageDblClick(Sender: TObject); else mnuResetLocationClick(Sender); end; -{$IFDEF DEBUG} -/////////////////////////////////////////////////////////////////////////////// -procedure TMainForm.AppException(Sender: TObject; E: Exception); -var - frmException: TfrmException; -begin - frmException := TfrmException.Create(nil); - - JclLastExceptStackListToStrings(frmException.Memo1.Lines, False, True, True, False); - - frmException.Memo1.Lines.Insert(0,e.Message); - frmException.Memo1.Lines.Insert(1,''); - - frmException.ShowModal; -end; -{$ENDIF} - /////////////////////////////////////////////////////////////////////////////// procedure TMainForm.tbShowAlphaClick(Sender: TObject); begin @@ -5972,9 +6235,15 @@ procedure TMainForm.FormKeyUpDown(Sender: TObject; var Key: Word; procedure TMainForm.ListViewChanging(Sender: TObject; Item: TListItem; Change: TItemChange; var AllowChange: Boolean); +var sc, fc: string; begin -{ if (Item = nil) then exit; - if (Trim(Item.Caption) = Trim(maincp.name)) and + if (Item = nil) or (Sender <> ListView1) then exit; + + sc := ''; fc := ''; + if (ListView1.Selected <> nil) then sc := ListView1.Selected.Caption; + if (ListView1.ItemFocused <> nil) then fc := ListView1.ItemFocused.Caption; + + if (Trim(Item.Caption) = Trim(maincp.name)) and (Item.Selected) and (Item.Selected) and (Change = ctState) then begin if (DoNotAskAboutChange = true) then @@ -5983,19 +6252,41 @@ procedure TMainForm.ListViewChanging(Sender: TObject; Item: TListItem; end; if (UndoIndex <> 0) then begin + // hack + if (LastCaptionSel = sc) and (LastCaptionFoc = fc) then begin + AllowChange := LastDecision; + if Not AllowChange then begin + ListView1.OnChange := nil; + ListView1.OnChanging := nil; + ListView1.Selected := Item; + ListView1.ItemFocused := Item; + ListView1.OnChanging := ListViewChanging; + ListView1.OnChange := ListViewChange; + end; + Exit; + end; + + LastCaptionSel := sc; + LastCaptionFoc := fc; + if Application.MessageBox('Do you really want to open another flame? All changes made to the current flame will be lost.', 'Apophysis', MB_ICONWARNING or MB_YESNO) <> IDYES then begin AllowChange := false; + ListView1.OnChange := nil; ListView1.OnChanging := nil; - ListView1.Selected := nil; + ListView1.Selected := Item; + ListView1.ItemFocused := Item; ListView1.OnChanging := ListViewChanging; + ListView1.OnChange := ListViewChange; end else begin AllowChange := true; end; + + LastDecision := AllowChange; end; - end; } + end; end; procedure TMainForm.ListViewInfoTip(Sender: TObject; Item: TListItem; @@ -6065,27 +6356,6 @@ procedure TMainForm.btnViewListClick(Sender: TObject); ClassicListMode := true; end; -procedure TMainForm.TBThumbThumbnailClick(Sender: TdwTaskbarThumbnailItem); -var - idx:integer; -begin - idx:=Sender.Index; - if (idx = 0) then - mnuSaveAsClick(nil) - else if (idx = 1) then - mnuRenderClick(nil) - else if (idx = 2) then - mnuCopyClick(nil) - else if (idx = 3) then - mnuPasteClick(nil) - else if (idx = 4) then - mnuMutateClick(nil) - else if (idx = 5) then - mnuEditorClick(nil) - else if (idx = 6) then - mnuAdjustClick(nil); -end; - procedure TMainForm.ListView1Click(Sender: TObject); begin //MissingStuff := ''; @@ -6100,6 +6370,13 @@ procedure TMainForm.XmlScannerEndTag(Sender: TObject; TagName: String); end; end; +procedure TMainForm.ToolButton19Click(Sender: TObject); +begin + AdjustForm.UpdateDisplay; + AdjustForm.PageControl.TabIndex:=4; + AdjustForm.Show; +end; + procedure TMainForm.ToolButton7Click(Sender: TObject); begin if (LoadForm.Showing = false) then LoadForm.Show; @@ -6116,8 +6393,9 @@ procedure TMainForm.ToolButton8Click(Sender: TObject); procedure TMainForm.FormResize(Sender: TObject); begin - if (MainForm.Width <= 756) then ToolBar.Height := 60 - else ToolBar.Height := 26; + if (MainForm.Width <= TbBreakWidth) then + Toolbar.Height := 26 * 2 + 8 + else Toolbar.Height := 26; end; function Split(const fText: String; const fSep: Char; fTrim: Boolean=false; fQuotes: Boolean=false):TStringList; @@ -6279,11 +6557,14 @@ procedure TMainForm.Restorelastautosave1Click(Sender: TObject); var fn:string; begin if (not fileexists(AutoSavePath)) then begin - Application.MessageBox(PAnsiChar(TextByKey('main-status-noautosave')), PAnsiChar('Apophysis'), MB_ICONERROR); + Application.MessageBox(PChar(TextByKey('main-status-noautosave')), PChar('Apophysis'), MB_ICONERROR); exit; end; +{$ifdef DisableScripting} +{$else} ScriptEditor.Stopped := True; +{$endif} fn := AutoSavePath; MainForm.CurrentFileName := fn; LastOpenFile := fn; @@ -6367,8 +6648,11 @@ procedure TMainForm.mnuTurnFlameToScriptClick(Sender: TObject); txt: string; begin txt := Trim(FlameToXML(Maincp, false, false)); + {$ifdef DisableScripting} +{$else} ScriptEditor.ScriptFromFlame(txt); ScriptEditor.Show; +{$endif} end; constructor TThumbnailThread.Create(SourceFile : string; FlameNames : TstringList); @@ -6544,7 +6828,7 @@ procedure ListXMLSimple(FileName: string; sel: integer); p := Pos(' 0) then begin - MainForm.ListXMLScanner.LoadFromBuffer(PCHAR(FSTrings[i])); + MainForm.ListXMLScanner.LoadFromBuffer(TCharType(TStringType(FSTrings[i]))); MainForm.ListXMLScanner.Execute; if Trim(pname) = '' then @@ -6608,7 +6892,7 @@ procedure ListXMLThumbnails(FileName: string; sel: integer); p := Pos(' 0) then begin - MainForm.ListXMLScanner.LoadFromBuffer(PCHAR(FSTrings[i])); + MainForm.ListXMLScanner.LoadFromBuffer(PANSICHAR(AnsiString(FSTrings[i]))); MainForm.ListXMLScanner.Execute; if Trim(pname) = '' then @@ -6672,191 +6956,72 @@ procedure TMainForm.mnuReportFlameClick(Sender: TObject); LoadForm.Output.Text := LoadForm.Output.Text + #13#10 + str + #13#10; end; -function TMainForm.GetExportChaoticaCP(var fn: string; var cp1: TControlPoint) : boolean; +procedure TMainForm.mnuExportChaoticaClick(Sender: TObject); begin - cp1 := TControlPoint.Create; - cp1.copy(Maincp); - ExportCDialog.ImageWidth := ExportWidth; - ExportCDialog.ImageHeight := ExportHeight; - ExportCDialog.Sample_density := ExportDensity; - ExportCDialog.Filter_Radius := ExportFilter; - ExportCDialog.Oversample := ExportOversample; - - ExportCDialog.Filename := RenderPath + Maincp.name + '.png'; - if ExportCDialog.ShowModal = mrOK then begin - fn := ChangeFileExt(ExportCDialog.Filename, '.flame'); - - ExportWidth := ExportCDialog.ImageWidth; - ExportHeight := ExportCDialog.ImageHeight; - //ExportDensity := ExportCDialog.Sample_density; - ExportFilter := ExportCDialog.Filter_Radius; - ExportOversample := ExportCDialog.Oversample; - ExportGammaTreshold := ExportCDialog.GammaTreshold; - - //cp1.sample_density := ExportDensity; - cp1.spatial_oversample := ExportOversample; - cp1.spatial_filter_radius := ExportFilter; - cp1.gamma_threshold := ExportGammaTreshold; - - if (cp1.width <> ExportWidth) or (cp1.Height <> ExportHeight) then - cp1.AdjustScale(ExportWidth, ExportHeight); - - Result := true; - end else begin - cp1.Destroy; - fn := ''; - Result := false; - end; + // + MainCP.FillUsedPlugins; + C_ExecuteChaotica(FlameToXml(MainCp, false, false), MainCp.used_plugins, UseX64IfPossible); end; -procedure TMainForm.mnuExportChaoticaClick(Sender: TObject); -const - re_root : string = '(.*?)'; - re_var : string = ''; - re_attrib : string = '([0-9a-z_]+)="(.*?)"'; -var - compatfile: string; - exepath : string; - - root_attribs : string; - root_content : string; - var_attribs : string; - - find_attribs : TPerlRegEx; - found_attrib : boolean; - attrib_name : string; - attrib_match : string; - - find_var : TPerlRegEx; - found_var : boolean; - var_index : integer; - - fileptr : TextFile; - buffer, xml : string; - - dll_supported : boolean; - supported_variations : TStringList; - - used_var : integer; - supported_var : integer; - found_in_supported : boolean; - unsupported_present : boolean; - do_continue : boolean; - - out_fn : string; - out_list : TStringList; - out_cp : TControlPoint; +procedure TMainForm.mnuManualClick(Sender: TObject); begin - if (not fileExists(ChaoticaPath)) then begin - MessageBox(0, PAnsiChar(TextByKey('main-status-nochaotica')), 'Apophysis', MB_ICONERROR); - exit; - end; - - compatFile := ExtractFilePath(ChaoticaPath) + 'Variation_Compatibility.xml'; - if (not fileExists(compatFile)) then - if MessageBox(0, PAnsiChar(TextByKey('main-status-chaoticacompatmissing')), - 'Apophysis', MB_ICONWARNING or MB_YESNO) = ID_NO then exit - else begin - AssignFile(fileptr, compatFile); - Reset(fileptr); - while not EOF(fileptr) do begin - ReadLn(fileptr, buffer) ; - xml := xml + #13#10 + buffer; - end; - CloseFile(fileptr); - end; - - find_attribs := TPerlRegEx.Create(nil); - find_var := TPerlRegEx.Create(nil); - - find_attribs.RegEx := re_attrib; - find_var.RegEx := re_var; - - find_attribs.Options := [preSingleLine, preCaseless]; - find_var.Options := [preSingleLine, preCaseless]; - - root_attribs := GetStringPart(xml, re_root, 1, ''); - root_content := GetStringPart(xml, re_root, 2, ''); - - find_attribs.Subject := root_attribs; - found_attrib := find_attribs.Match; - - while found_attrib do begin - attrib_match := find_attribs.MatchedExpression; - attrib_name := Lowercase(find_attribs.SubExpressions[1]); - - if (attrib_name = 'supports_dll_plugins') then - dll_supported := Lowercase(GetStringPart(attrib_match, re_attrib, 2, '')) = 'true'; - - found_attrib := find_attribs.MatchAgain; - end; - - find_var.Subject := root_content; - found_var := find_var.Match; - var_index := 0; - supported_variations := TStringList.Create; - dll_supported := false; - - while found_var do begin - find_attribs.Subject := find_var.SubExpressions[1]; - found_attrib := find_attribs.Match; - - while found_attrib do begin - attrib_match := find_attribs.MatchedExpression; - attrib_name := Lowercase(find_attribs.SubExpressions[1]); - - if (attrib_name = 'name') then - supported_variations.Add(GetStringPart(attrib_match, re_attrib, 2, '')); - - found_attrib := find_attribs.MatchAgain; - end; - - found_var := find_var.MatchAgain; - end; - - unsupported_present := false; - if (not dll_supported) then for used_var := 0 to MainCp.used_plugins.Count - 1 do - unsupported_present := unsupported_present or - (supported_variations.IndexOf(MainCp.used_plugins[used_var]) < 0); - - do_continue := true; - if unsupported_present then do_continue := MessageBox(0, - PAnsiChar(TextByKey('main-status-oldchaotica')), - 'Apophysis', MB_ICONWARNING or MB_YESNO) = ID_YES; + WinShellOpen('http://dl.dropbox.com/u/20949676/ApophysisUserManual/index.html'); +end; - if do_continue then begin - if (not GetExportChaoticaCp(out_fn, out_cp)) then begin - supported_variations.Destroy; - find_attribs.Destroy; - find_var.Destroy; - exit; +procedure TMainForm.CreateSubstMap; +begin + SubstSource.Add('cross2'); SubstTarget.Add('cross'); + SubstSource.Add('Epispiral'); SubstTarget.Add('epispiral'); + SubstSource.Add('Epispiral_n'); SubstTarget.Add('epispiral_n'); + SubstSource.Add('Epispiral_thickness'); SubstTarget.Add('epispiral_thickness'); + SubstSource.Add('Epispiral_holes'); SubstTarget.Add('epispiral_holes'); + SubstSource.Add('bwraps2'); SubstTarget.Add('bwraps'); + SubstSource.Add('bwraps2_cellsize'); SubstTarget.Add('bwraps_cellsize'); + SubstSource.Add('bwraps2_space'); SubstTarget.Add('bwraps_space'); + SubstSource.Add('bwraps2_gain'); SubstTarget.Add('bwraps_gain'); + SubstSource.Add('bwraps2_inner_twist'); SubstTarget.Add('bwraps_inner_twist'); + SubstSource.Add('bwraps2_outer_twist'); SubstTarget.Add('bwraps_outer_twist'); + SubstSource.Add('pre_bwraps2'); SubstTarget.Add('pre_bwraps'); + SubstSource.Add('pre_bwraps2_cellsize'); SubstTarget.Add('pre_bwraps_cellsize'); + SubstSource.Add('pre_bwraps2_space'); SubstTarget.Add('pre_bwraps_space'); + SubstSource.Add('pre_bwraps2_gain'); SubstTarget.Add('pre_bwraps_gain'); + SubstSource.Add('pre_bwraps2_inner_twist'); SubstTarget.Add('pre_bwraps_inner_twist'); + SubstSource.Add('pre_bwraps2_outer_twist'); SubstTarget.Add('pre_bwraps_outer_twist'); + SubstSource.Add('post_bwraps2'); SubstTarget.Add('post_bwraps'); + SubstSource.Add('post_bwraps2_cellsize'); SubstTarget.Add('post_bwraps_cellsize'); + SubstSource.Add('post_bwraps2_space'); SubstTarget.Add('post_bwraps_space'); + SubstSource.Add('post_bwraps2_gain'); SubstTarget.Add('post_bwraps_gain'); + SubstSource.Add('post_bwraps2_inner_twist'); SubstTarget.Add('post_bwraps_inner_twist'); + SubstSource.Add('post_bwraps2_outer_twist'); SubstTarget.Add('post_bwraps_outer_twist'); + SubstSource.Add('bwraps7'); SubstTarget.Add('bwraps'); + SubstSource.Add('bwraps7_cellsize'); SubstTarget.Add('bwraps_cellsize'); + SubstSource.Add('bwraps7_space'); SubstTarget.Add('bwraps_space'); + SubstSource.Add('bwraps7_gain'); SubstTarget.Add('bwraps_gain'); + SubstSource.Add('bwraps7_inner_twist'); SubstTarget.Add('bwraps_inner_twist'); + SubstSource.Add('bwraps7_outer_twist'); SubstTarget.Add('bwraps_outer_twist'); + SubstSource.Add('logn'); SubstTarget.Add('log'); + SubstSource.Add('logn_base'); SubstTarget.Add('log_base'); +end; +function TMainForm.ReadWithSubst(Attributes: TAttrList; attrname: string): string; +var i: integer; v: TStringType; +begin + v := Attributes.Value(TStringType(attrname)); + if (v <> '') then begin + Result := String(v); + Exit; + end; + + for i := 0 to SubstTarget.Count - 1 do begin + if (SubstTarget[i] = attrname) then begin + v := Attributes.Value(TStringType(SubstSource[i])); + if (v <> '') then begin + Result := String(v); + Exit; + end; end; - - out_list := TstringList.Create; - out_list.Text := FlameToXML(out_cp, false, false); - out_list.SaveToFile(GetEnvironmentVariable('TEMP') + '\chaotica_export.flame'); - out_list.Destroy; - - if dll_supported then ShellExecute( - application.handle, PChar('open'), pchar(ChaoticaPath), - PChar('"' + GetEnvironmentVariable('TEMP') + '\chaotica_export.flame" "' + - ExtractFilePath(Application.ExeName) + 'Plugins' + '"'), - PChar(ExtractFilePath(ChaoticaPath)), SW_SHOWNORMAL) - else ShellExecute( - application.handle, PChar('open'), pchar(ChaoticaPath), - PChar('"' + GetEnvironmentVariable('TEMP') + '\chaotica_export.flame"'), - PChar(ExtractFilePath(ChaoticaPath)), SW_SHOWNORMAL); end; - supported_variations.Destroy; - find_attribs.Destroy; - find_var.Destroy; -end; - - -procedure TMainForm.mnuManualClick(Sender: TObject); -begin - WinShellOpen('http://dl.dropbox.com/u/20949676/ApophysisUserManual/index.html'); + Result := ''; end; end. diff --git a/Source/Forms/Mutate.ddp b/Source/Forms/Mutate.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/Mutate.ddp and /dev/null differ diff --git a/Source/Forms/Mutate.dfm b/Source/Forms/Mutate.dfm index 12789f3..05bbb5d 100644 --- a/Source/Forms/Mutate.dfm +++ b/Source/Forms/Mutate.dfm @@ -297,7 +297,6 @@ object MutateForm: TMutateForm Style = csDropDownList Anchors = [akLeft, akTop, akRight] DropDownCount = 16 - ItemHeight = 13 TabOrder = 1 OnChange = cmbTrendChange Items.Strings = ( diff --git a/Source/Forms/Mutate.pas b/Source/Forms/Mutate.pas index bfa4ce4..82240a7 100644 --- a/Source/Forms/Mutate.pas +++ b/Source/Forms/Mutate.pas @@ -27,7 +27,7 @@ interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, ControlPoint, ComCtrls, Menus, Buttons, Cmap, - Render, Translation; + RenderingInterface, Translation, Curves; type TMutateForm = class(TForm) @@ -285,6 +285,8 @@ procedure TMutateForm.ShowMutants; procedure TMutateForm.Interpolate; var i, j, k: Integer; begin + if MainCp = nil then Exit; + for i := 1 to 8 do begin if bstop then exit; @@ -364,7 +366,7 @@ procedure TMutateForm.FormShow(Sender: TObject); finally Registry.Free; end; - if cps[0].xform[0].density <> 0 then begin // hmm...!? + if (cps[0].xform[0].density <> 0) and Assigned(MainCp) then begin // hmm...!? Interpolate; ShowMain; ShowMutants; @@ -690,3 +692,4 @@ procedure TMutateForm.Panel10Resize(Sender: TObject); end. + diff --git a/Source/Forms/Options.ddp b/Source/Forms/Options.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/Options.ddp and /dev/null differ diff --git a/Source/Forms/Options.dfm b/Source/Forms/Options.dfm index 814cf55..ad2cee4 100644 --- a/Source/Forms/Options.dfm +++ b/Source/Forms/Options.dfm @@ -83,7 +83,7 @@ object OptionsForm: TOptionsForm Width = 297 Height = 69 Caption = 'On render complete' - TabOrder = 3 + TabOrder = 2 object btnBrowseSound: TSpeedButton Left = 264 Top = 41 @@ -198,40 +198,23 @@ object OptionsForm: TOptionsForm TabOrder = 1 end end - object btnOK: TButton - Left = 304 - Top = 409 - Width = 86 - Height = 25 - Anchors = [akRight, akBottom] - Caption = 'OK' - Default = True - TabOrder = 0 - OnClick = btnOKClick - end - object btnCancel: TButton - Left = 397 - Top = 409 - Width = 86 - Height = 25 - Anchors = [akRight, akBottom] - Caption = 'Cancel' - TabOrder = 1 - OnClick = btnCancelClick - end object Tabs: TPageControl Left = 8 Top = 8 Width = 475 Height = 396 - ActivePage = EditorPage + ActivePage = GeneralPage Anchors = [akLeft, akTop, akRight, akBottom] MultiLine = True - TabOrder = 2 + TabOrder = 3 TabStop = False object GeneralPage: TTabSheet HelpContext = 1 Caption = 'General' + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 DesignSize = ( 467 368) @@ -379,15 +362,22 @@ object OptionsForm: TOptionsForm Width = 113 Height = 21 Style = csDropDownList - ItemHeight = 13 ItemIndex = 0 TabOrder = 9 Text = 'Off' Items.Strings = ( 'Off' '2' + '3' '4' - '8') + '5' + '6' + '7' + '8' + '9' + '10' + '11' + '12') end object pnlPNGTransparency: TPanel Left = 8 @@ -560,7 +550,6 @@ object OptionsForm: TOptionsForm Width = 323 Height = 21 Anchors = [akLeft, akTop, akRight] - ItemHeight = 13 TabOrder = 18 end object cbPNGTransparency: TComboBox @@ -569,7 +558,6 @@ object OptionsForm: TOptionsForm Width = 113 Height = 21 Style = csDropDownList - ItemHeight = 13 ItemIndex = 0 TabOrder = 13 Text = 'Disabled' @@ -582,7 +570,6 @@ object OptionsForm: TOptionsForm Top = 36 Width = 113 Height = 21 - ItemHeight = 13 ItemIndex = 2 TabOrder = 11 Text = '100' @@ -592,10 +579,23 @@ object OptionsForm: TOptionsForm '100' '120') end + object cbSinglePrecision: TCheckBox + Left = 236 + Top = 243 + Width = 193 + Height = 17 + Caption = 'Use single-precision buffers' + TabOrder = 19 + Visible = False + end end object EditorPage: TTabSheet Caption = 'Editor' ImageIndex = 8 + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 DesignSize = ( 467 368) @@ -889,6 +889,10 @@ object OptionsForm: TOptionsForm end object DisplayPage: TTabSheet Caption = 'Display' + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 DesignSize = ( 467 368) @@ -1157,7 +1161,6 @@ object OptionsForm: TOptionsForm Top = 16 Width = 73 Height = 21 - ItemHeight = 13 TabOrder = 1 Items.Strings = ( '0' @@ -1183,6 +1186,10 @@ object OptionsForm: TOptionsForm end object RandomPage: TTabSheet Caption = 'Random' + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 DesignSize = ( 467 368) @@ -1495,7 +1502,6 @@ object OptionsForm: TOptionsForm Height = 21 HelpContext = 1024 Style = csDropDownList - ItemHeight = 13 TabOrder = 0 OnChange = cmbSymTypeChange Items.Strings = ( @@ -1584,6 +1590,10 @@ object OptionsForm: TOptionsForm object VariationsPage: TTabSheet Caption = 'Variations' ImageIndex = 4 + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 DesignSize = ( 467 368) @@ -1624,6 +1634,10 @@ object OptionsForm: TOptionsForm object TabSheet1: TTabSheet Caption = 'Gradient' ImageIndex = 5 + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 DesignSize = ( 467 368) @@ -1687,7 +1701,7 @@ object OptionsForm: TOptionsForm object udMinHue: TUpDown Left = 185 Top = 20 - Width = 13 + Width = 15 Height = 21 HelpContext = 1032 Associate = txtMinHue @@ -1721,7 +1735,7 @@ object OptionsForm: TOptionsForm object udMaxHue: TUpDown Left = 185 Top = 44 - Width = 13 + Width = 15 Height = 21 HelpContext = 1033 Associate = txtMaxHue @@ -1785,7 +1799,7 @@ object OptionsForm: TOptionsForm object udMinSat: TUpDown Left = 185 Top = 20 - Width = 13 + Width = 15 Height = 21 HelpContext = 1034 Associate = txtMinSat @@ -1804,7 +1818,7 @@ object OptionsForm: TOptionsForm object udmaxSat: TUpDown Left = 185 Top = 44 - Width = 13 + Width = 15 Height = 21 HelpContext = 1035 Associate = txtMaxSat @@ -1856,7 +1870,7 @@ object OptionsForm: TOptionsForm object udMinLum: TUpDown Left = 185 Top = 20 - Width = 13 + Width = 15 Height = 21 HelpContext = 1036 Associate = txtMinLum @@ -1877,7 +1891,7 @@ object OptionsForm: TOptionsForm object udMaxLum: TUpDown Left = 185 Top = 44 - Width = 13 + Width = 15 Height = 21 HelpContext = 1037 Associate = txtMaxLum @@ -1930,7 +1944,7 @@ object OptionsForm: TOptionsForm object udMinNodes: TUpDown Left = 185 Top = 20 - Width = 13 + Width = 15 Height = 21 HelpContext = 1030 Associate = txtMinNodes @@ -1952,7 +1966,7 @@ object OptionsForm: TOptionsForm object udMaxNodes: TUpDown Left = 185 Top = 44 - Width = 13 + Width = 15 Height = 21 HelpContext = 1031 Associate = txtMaxNodes @@ -1976,6 +1990,10 @@ object OptionsForm: TOptionsForm object TabSheet6: TTabSheet Caption = 'UPR' ImageIndex = 5 + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 DesignSize = ( 467 368) @@ -2219,6 +2237,10 @@ object OptionsForm: TOptionsForm Enabled = False ImageIndex = 6 TabVisible = False + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 object GroupBox6: TGroupBox Left = 8 Top = 6 @@ -2301,6 +2323,10 @@ object OptionsForm: TOptionsForm object PathsPage: TTabSheet Caption = 'Environment' ImageIndex = 7 + ExplicitLeft = 0 + ExplicitTop = 0 + ExplicitWidth = 0 + ExplicitHeight = 0 DesignSize = ( 467 368) @@ -2531,14 +2557,14 @@ object OptionsForm: TOptionsForm end object Label49: TLabel Left = 245 - Top = 212 + Top = 236 Width = 37 Height = 13 Caption = 'minutes' end object btnFindDefaultSaveFile: TSpeedButton Left = 437 - Top = 183 + Top = 207 Width = 24 Height = 24 Hint = 'Browse...' @@ -2580,9 +2606,54 @@ object OptionsForm: TOptionsForm ShowHint = True OnClick = btnFindDefaultSaveFileClick end + object btnPluginPath: TSpeedButton + Left = 437 + Top = 128 + Width = 24 + Height = 24 + Hint = 'Browse...' + Anchors = [akTop, akRight] + Flat = True + Font.Charset = ANSI_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Arial' + Font.Style = [fsBold] + Glyph.Data = { + 36030000424D3603000000000000360000002800000010000000100000000100 + 18000000000000030000120B0000120B00000000000000000000FF00FFFF00FF + FF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00 + FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF + 00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FF75848F66808F + 607987576E7B4E626F4456613948522E3A43252E351B222914191E0E12160E13 + 18FF00FFFF00FFFF00FF77879289A1AB6AB2D4008FCD008FCD008FCD048CC708 + 88BE0F82B4157CA91B779F1F7296224B5C87A2ABFF00FFFF00FF7A8A957EBED3 + 8AA4AE7EDCFF5FCFFF55CBFF4CC4FA41BCF537B3F02EAAEB24A0E5138CD42367 + 805E696DFF00FFFF00FF7D8E9879D2EC8BA4AD89C2CE71D8FF65D3FF5CCEFF51 + C9FE49C1FA3FB9F534B0EE29A8E91085CD224B5B98B2BAFF00FF80919C81D7EF + 7DC5E08CA6B080DDFE68D3FF67D4FF62D1FF58CDFF4EC7FC46BEF73BB6F231AC + EC2569817A95A1FF00FF83959F89DCF18CE2FF8DA8B18CBAC774D8FF67D4FF67 + D4FF67D4FF5FD0FF54CDFF4BC5FC41BBF72EA2DB51677498B2BA869AA392E1F2 + 98E8FD80C4DE8EA7B081DEFD84E0FF84E0FF84E0FF84E0FF81DFFF7BDDFF74D8 + FF6BD6FF56A9D18F9BA4889CA59AE6F39FEBFB98E8FE8BACB98BACB98AAAB788 + A6B386A3AF839FAA819AA67F95A17C919D7A8E99798B957788938BA0A8A0EAF6 + A6EEF99FEBFB98E8FE7ADAFF67D4FF67D4FF67D4FF67D4FF67D4FF67D4FF7788 + 93FF00FFFF00FFFF00FF8EA2ABA7EEF6ABF0F7A6EEF99FEBFB98E8FD71D4FB89 + 9EA78699A382949F7E909A7A8C97778893FF00FFFF00FFFF00FF8FA4ACA0D2DA + ABF0F7ABF0F7A6EEF99FEBFB8DA1AAB5CBD0FF00FFFF00FFFF00FFFF00FFFF00 + FFFF00FFFF00FFFF00FFBDCED48FA4AC8FA4AC8FA4AC8FA4AC8FA4ACB5CBD0FF + 00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FF + FF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00 + FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF + 00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FFFF00FF} + ParentFont = False + ParentShowHint = False + ShowHint = True + OnClick = btnPluginPathClick + end object chkRememberLastOpen: TCheckBox Left = 8 - Top = 136 + Top = 160 Width = 433 Height = 17 Caption = 'Remember last opened parameters' @@ -2704,7 +2775,7 @@ object OptionsForm: TOptionsForm end object cbEnableAutosave: TCheckBox Left = 8 - Top = 160 + Top = 184 Width = 425 Height = 17 Caption = 'Enable autosave' @@ -2713,7 +2784,7 @@ object OptionsForm: TOptionsForm end object Panel44: TPanel Left = 24 - Top = 184 + Top = 208 Width = 113 Height = 21 Cursor = crArrow @@ -2725,7 +2796,7 @@ object OptionsForm: TOptionsForm end object txtDefaultSaveFile: TEdit Left = 136 - Top = 184 + Top = 208 Width = 302 Height = 21 HelpContext = 1000 @@ -2735,7 +2806,7 @@ object OptionsForm: TOptionsForm end object Panel45: TPanel Left = 24 - Top = 208 + Top = 232 Width = 113 Height = 21 Cursor = crArrow @@ -2747,11 +2818,10 @@ object OptionsForm: TOptionsForm end object cbFreq: TComboBox Left = 136 - Top = 208 + Top = 232 Width = 105 Height = 21 Style = csDropDownList - ItemHeight = 13 ItemIndex = 2 TabOrder = 11 Text = '5' @@ -2763,17 +2833,17 @@ object OptionsForm: TOptionsForm end object GroupBox3: TGroupBox Left = 8 - Top = 240 + Top = 264 Width = 457 - Height = 105 - Caption = 'Chaotica' + Height = 73 + Caption = 'Chaotica 0.45+' TabOrder = 16 DesignSize = ( 457 - 105) + 73) object btnChaotica: TSpeedButton Left = 425 - Top = 26 + Top = 18 Width = 24 Height = 24 Hint = 'Browse...' @@ -2818,7 +2888,7 @@ object OptionsForm: TOptionsForm end object btnChaotica64: TSpeedButton Left = 425 - Top = 50 + Top = 98 Width = 24 Height = 24 Hint = 'Browse...' @@ -2859,23 +2929,24 @@ object OptionsForm: TOptionsForm ParentFont = False ParentShowHint = False ShowHint = True + Visible = False OnClick = btnChaoticaClick end object Panel47: TPanel Left = 8 - Top = 28 + Top = 20 Width = 129 Height = 21 Cursor = crArrow BevelOuter = bvLowered - Caption = 'File name (x86)' + Caption = 'Location' ParentShowHint = False ShowHint = True TabOrder = 1 end object cbC64: TCheckBox Left = 8 - Top = 80 + Top = 48 Width = 441 Height = 17 Anchors = [akLeft, akTop, akRight] @@ -2884,7 +2955,7 @@ object OptionsForm: TOptionsForm end object txtChaotica: TEdit Left = 136 - Top = 28 + Top = 20 Width = 289 Height = 21 HelpContext = 1000 @@ -2895,7 +2966,7 @@ object OptionsForm: TOptionsForm end object Panel49: TPanel Left = 8 - Top = 52 + Top = 100 Width = 129 Height = 21 Cursor = crArrow @@ -2904,10 +2975,11 @@ object OptionsForm: TOptionsForm ParentShowHint = False ShowHint = True TabOrder = 3 + Visible = False end object txtChaotica64: TEdit Left = 136 - Top = 52 + Top = 100 Width = 289 Height = 21 HelpContext = 1000 @@ -2915,10 +2987,55 @@ object OptionsForm: TOptionsForm ParentShowHint = False ShowHint = False TabOrder = 4 + Visible = False end end + object Panel50: TPanel + Left = 8 + Top = 130 + Width = 129 + Height = 21 + Cursor = crArrow + BevelOuter = bvLowered + Caption = 'Plugin folder' + ParentShowHint = False + ShowHint = True + TabOrder = 17 + end + object txtPluginFolder: TEdit + Left = 136 + Top = 130 + Width = 302 + Height = 21 + HelpContext = 1000 + Anchors = [akLeft, akTop, akRight] + ParentShowHint = False + ShowHint = False + TabOrder = 18 + end end end + object btnOK: TButton + Left = 304 + Top = 409 + Width = 86 + Height = 25 + Anchors = [akRight, akBottom] + Caption = 'OK' + Default = True + TabOrder = 0 + OnClick = btnOKClick + end + object btnCancel: TButton + Left = 397 + Top = 409 + Width = 86 + Height = 25 + Anchors = [akRight, akBottom] + Caption = 'Cancel' + TabOrder = 1 + OnClick = btnCancelClick + end object OpenDialog: TOpenDialog Left = 8 Top = 408 diff --git a/Source/Forms/Options.pas b/Source/Forms/Options.pas index b61eb9a..9e8b19d 100644 --- a/Source/Forms/Options.pas +++ b/Source/Forms/Options.pas @@ -28,7 +28,7 @@ interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls, ExtCtrls, Buttons, Registry, Mask, CheckLst, - MMSystem, Translation, PerlRegEx, RegexHelper; + MMSystem, Translation, RegexHelper, FileCtrl, StrUtils, ShellAPI, ShlObj; type TOptionsForm = class(TForm) @@ -36,105 +36,27 @@ TOptionsForm = class(TForm) btnCancel: TButton; OpenDialog: TOpenDialog; Label45: TLabel; + GroupBox15: TGroupBox; + btnBrowseSound: TSpeedButton; + btnPlay: TSpeedButton; + Label44: TLabel; + txtSoundFile: TEdit; + chkPlaysound: TCheckBox; Tabs: TPageControl; GeneralPage: TTabSheet; + SpeedButton1: TSpeedButton; + pnlJPEGQuality: TPanel; chkConfirmDel: TCheckBox; chkOldPaletteFormat: TCheckBox; chkConfirmExit: TCheckBox; chkConfirmStopRender: TCheckBox; cbUseTemplate: TCheckBox; - EditorPage: TTabSheet; - GroupBox1: TGroupBox; - chkUseXFormColor: TCheckBox; - chkHelpers: TCheckBox; - rgReferenceMode: TRadioGroup; - GroupBox21: TGroupBox; - chkAxisLock: TCheckBox; - chkExtendedEdit: TCheckBox; - chkXaosRebuild: TCheckBox; - DisplayPage: TTabSheet; - GroupBox2: TGroupBox; - txtLowQuality: TEdit; - txtMediumQuality: TEdit; - txtHighQuality: TEdit; - grpRendering: TGroupBox; - txtSampleDensity: TEdit; - txtGamma: TEdit; - txtBrightness: TEdit; - txtVibrancy: TEdit; - txtOversample: TEdit; - txtFilterRadius: TEdit; - txtGammaThreshold: TEdit; - GroupBox20: TGroupBox; - Label48: TLabel; - chkShowTransparency: TCheckBox; - chkExtendMainPreview: TCheckBox; - cbExtendPercent: TComboBox; - RandomPage: TTabSheet; - gpNumberOfTransforms: TGroupBox; - txtMinXForms: TEdit; - txtMaxXforms: TEdit; - udMinXforms: TUpDown; - udMaxXForms: TUpDown; - gpFlameTitlePrefix: TGroupBox; - txtRandomPrefix: TEdit; - txtBatchSize: TEdit; - udBatchSize: TUpDown; - gpMutationTransforms: TGroupBox; - txtMinMutate: TEdit; - txtMaxMutate: TEdit; - udMinMutate: TUpDown; - udMaxMutate: TUpDown; - gpForcedSymmetry: TGroupBox; - cmbSymType: TComboBox; - txtSymOrder: TEdit; - udSymOrder: TUpDown; - txtSymNVars: TEdit; - udSymNVars: TUpDown; - VariationsPage: TTabSheet; - btnSetAll: TButton; - btnClearAll: TButton; - TabSheet1: TTabSheet; - GroupBox13: TGroupBox; - txtNumtries: TEdit; - txtTryLength: TEdit; - TabSheet6: TTabSheet; - UPRPage: TPageControl; - GroupBox11: TGroupBox; - txtUPRWidth: TEdit; - txtUPRHeight: TEdit; - GroupBox9: TGroupBox; - txtFIterDensity: TEdit; - txtUPRFilterRadius: TEdit; - txtUPROversample: TEdit; - GroupBox4: TGroupBox; - txtFCIdent: TEdit; - txtFCFile: TEdit; - GroupBox5: TGroupBox; - txtFFIdent: TEdit; - txtFFFile: TEdit; - chkAdjustDensity: TCheckBox; - TabSheet2: TTabSheet; - GroupBox6: TGroupBox; - Label5: TLabel; - Label6: TLabel; - Label15: TLabel; - txtNick: TEdit; - txtURL: TEdit; - txtPassword: TEdit; - GroupBox8: TGroupBox; - Label17: TLabel; - txtServer: TEdit; - PathsPage: TTabSheet; cbMissingPlugin: TCheckBox; cbEmbedThumbs: TCheckBox; chkShowRenderStats: TCheckBox; pnlMultithreading: TPanel; cbNrTheads: TComboBox; - pnlJPEGQuality: TPanel; - txtJPEGquality: TComboBox; pnlPNGTransparency: TPanel; - cbPNGTransparency: TComboBox; grpGuidelines: TGroupBox; cbGL: TCheckBox; pnlCenterLine: TPanel; @@ -148,7 +70,25 @@ TOptionsForm = class(TForm) pnlGoldenRatio: TPanel; rgRotationMode: TRadioGroup; rgZoomingMode: TRadioGroup; + Panel46: TPanel; + txtLanguageFile: TComboBox; + cbPNGTransparency: TComboBox; + txtJPEGquality: TComboBox; + cbSinglePrecision: TCheckBox; + EditorPage: TTabSheet; + GroupBox1: TGroupBox; + chkUseXFormColor: TCheckBox; + chkHelpers: TCheckBox; + rgReferenceMode: TRadioGroup; + GroupBox21: TGroupBox; + chkAxisLock: TCheckBox; + chkExtendedEdit: TCheckBox; + chkXaosRebuild: TCheckBox; grpEditorColors: TGroupBox; + pnlBackground: TPanel; + pnlReferenceC: TPanel; + pnlHelpers: TPanel; + pnlGrid: TPanel; pnlBackColor: TPanel; shBackground: TShape; pnlReference: TPanel; @@ -159,13 +99,19 @@ TOptionsForm = class(TForm) shGC1: TShape; pnlGridColor2: TPanel; shGC2: TShape; - pnlBackground: TPanel; - pnlReferenceC: TPanel; - pnlHelpers: TPanel; - pnlGrid: TPanel; chkShowAllXforms: TCheckBox; - pnlExtension: TPanel; - chkUseSmallThumbs: TCheckBox; + chkEnableEditorPreview: TCheckBox; + Panel48: TPanel; + tbEPTransparency: TTrackBar; + DisplayPage: TTabSheet; + GroupBox2: TGroupBox; + Panel8: TPanel; + Panel9: TPanel; + Panel10: TPanel; + txtHighQuality: TEdit; + txtMediumQuality: TEdit; + txtLowQuality: TEdit; + grpRendering: TGroupBox; Panel1: TPanel; Panel2: TPanel; Panel3: TPanel; @@ -173,31 +119,72 @@ TOptionsForm = class(TForm) Panel5: TPanel; Panel6: TPanel; Panel7: TPanel; - Panel8: TPanel; - Panel9: TPanel; - Panel10: TPanel; + txtGammaThreshold: TEdit; + txtFilterRadius: TEdit; + txtOversample: TEdit; + txtVibrancy: TEdit; + txtBrightness: TEdit; + txtGamma: TEdit; + txtSampleDensity: TEdit; + GroupBox20: TGroupBox; + Label48: TLabel; + chkShowTransparency: TCheckBox; + chkExtendMainPreview: TCheckBox; + pnlExtension: TPanel; + cbExtendPercent: TComboBox; + chkUseSmallThumbs: TCheckBox; + RandomPage: TTabSheet; + gpNumberOfTransforms: TGroupBox; + udMinXforms: TUpDown; + udMaxXForms: TUpDown; + Panel15: TPanel; + Panel16: TPanel; + txtMaxXforms: TEdit; + txtMinXForms: TEdit; + gpFlameTitlePrefix: TGroupBox; + udBatchSize: TUpDown; chkKeepBackground: TCheckBox; Panel11: TPanel; Panel12: TPanel; + txtBatchSize: TEdit; + txtRandomPrefix: TEdit; + gpMutationTransforms: TGroupBox; + udMinMutate: TUpDown; + udMaxMutate: TUpDown; Panel13: TPanel; Panel14: TPanel; - Panel15: TPanel; - Panel16: TPanel; + txtMaxMutate: TEdit; + txtMinMutate: TEdit; + gpForcedSymmetry: TGroupBox; + udSymOrder: TUpDown; + udSymNVars: TUpDown; Panel17: TPanel; Panel18: TPanel; Panel19: TPanel; - clbVarEnabled: TCheckListBox; + txtSymNVars: TEdit; + txtSymOrder: TEdit; + cmbSymType: TComboBox; grpGradient: TRadioGroup; GroupBox16: TGroupBox; btnGradientsFile: TSpeedButton; txtGradientsFile: TEdit; + VariationsPage: TTabSheet; + btnSetAll: TButton; + btnClearAll: TButton; + clbVarEnabled: TCheckListBox; + TabSheet1: TTabSheet; + GroupBox13: TGroupBox; + Panel28: TPanel; + Panel29: TPanel; + txtTryLength: TEdit; + txtNumtries: TEdit; GroupBox17: TGroupBox; udMinHue: TUpDown; - txtMinHue: TEdit; Panel20: TPanel; Panel21: TPanel; udMaxHue: TUpDown; txtMaxHue: TEdit; + txtMinHue: TEdit; GroupBox18: TGroupBox; Panel22: TPanel; Panel23: TPanel; @@ -219,60 +206,77 @@ TOptionsForm = class(TForm) txtMinNodes: TEdit; udMaxNodes: TUpDown; txtMaxNodes: TEdit; - Panel28: TPanel; - Panel29: TPanel; + TabSheet6: TTabSheet; + chkAdjustDensity: TCheckBox; + UPRPage: TPageControl; + GroupBox11: TGroupBox; + Panel37: TPanel; + Panel38: TPanel; + txtUPRHeight: TEdit; + txtUPRWidth: TEdit; + GroupBox9: TGroupBox; + Panel34: TPanel; + Panel35: TPanel; + Panel36: TPanel; + txtUPROversample: TEdit; + txtUPRFilterRadius: TEdit; + txtFIterDensity: TEdit; + GroupBox4: TGroupBox; Panel30: TPanel; Panel31: TPanel; + txtFCFile: TEdit; + txtFCIdent: TEdit; + GroupBox5: TGroupBox; Panel32: TPanel; Panel33: TPanel; - Panel34: TPanel; - Panel35: TPanel; - Panel36: TPanel; - Panel37: TPanel; - Panel38: TPanel; + txtFFFile: TEdit; + txtFFIdent: TEdit; + TabSheet2: TTabSheet; + GroupBox6: TGroupBox; + Label5: TLabel; + Label6: TLabel; + Label15: TLabel; + txtNick: TEdit; + txtURL: TEdit; + txtPassword: TEdit; + GroupBox8: TGroupBox; + Label17: TLabel; + txtServer: TEdit; + PathsPage: TTabSheet; + btnDefGradient: TSpeedButton; + btnSmooth: TSpeedButton; + SpeedButton2: TSpeedButton; + btnRenderer: TSpeedButton; + btnHelp: TSpeedButton; + Label49: TLabel; + btnFindDefaultSaveFile: TSpeedButton; chkRememberLastOpen: TCheckBox; Panel39: TPanel; txtDefParameterFile: TEdit; - btnDefGradient: TSpeedButton; - txtDefSmoothFile: TEdit; Panel40: TPanel; - btnSmooth: TSpeedButton; - txtLibrary: TEdit; - txtRenderer: TEdit; - txtHelp: TEdit; - SpeedButton2: TSpeedButton; + txtDefSmoothFile: TEdit; Panel41: TPanel; Panel42: TPanel; Panel43: TPanel; - btnRenderer: TSpeedButton; - btnHelp: TSpeedButton; - cbFreq: TComboBox; - txtDefaultSaveFile: TEdit; + txtLibrary: TEdit; + txtRenderer: TEdit; + txtHelp: TEdit; cbEnableAutosave: TCheckBox; - Label49: TLabel; - btnFindDefaultSaveFile: TSpeedButton; Panel44: TPanel; + txtDefaultSaveFile: TEdit; Panel45: TPanel; - GroupBox15: TGroupBox; - btnBrowseSound: TSpeedButton; - btnPlay: TSpeedButton; - Label44: TLabel; - txtSoundFile: TEdit; - chkPlaysound: TCheckBox; - Panel46: TPanel; - SpeedButton1: TSpeedButton; - txtLanguageFile: TComboBox; - chkEnableEditorPreview: TCheckBox; - Panel48: TPanel; - tbEPTransparency: TTrackBar; + cbFreq: TComboBox; GroupBox3: TGroupBox; - txtChaotica: TEdit; - Panel47: TPanel; btnChaotica: TSpeedButton; - cbC64: TCheckBox; btnChaotica64: TSpeedButton; + Panel47: TPanel; + cbC64: TCheckBox; + txtChaotica: TEdit; Panel49: TPanel; txtChaotica64: TEdit; + btnPluginPath: TSpeedButton; + Panel50: TPanel; + txtPluginFolder: TEdit; procedure chkEnableEditorPreviewClick(Sender: TObject); procedure btnChaoticaClick(Sender: TObject); procedure SpeedButton1Click(Sender: TObject); @@ -331,6 +335,7 @@ TOptionsForm = class(TForm) procedure cbEnableAutosaveClick(Sender: TObject); procedure btnHelpClick(Sender: TObject); procedure cbGLClick(Sender: TObject); + procedure btnPluginPathClick(Sender: TObject); private { Private declarations } @@ -404,8 +409,16 @@ procedure TOptionsForm.FormShow(Sender: TObject); cbNrTheads.ItemIndex := 0; case NrTreads of 2: cbNrTheads.ItemIndex := 1; - 4: cbNrTheads.ItemIndex := 2; - 8: cbNrTheads.ItemIndex := 3; + 3: cbNrTheads.ItemIndex := 2; + 4: cbNrTheads.ItemIndex := 3; + 5: cbNrTheads.ItemIndex := 4; + 6: cbNrTheads.ItemIndex := 5; + 7: cbNrTheads.ItemIndex := 6; + 8: cbNrTheads.ItemIndex := 7; + 9: cbNrTheads.ItemIndex := 8; + 10: cbNrTheads.ItemIndex := 9; + 11: cbNrTheads.ItemIndex := 10; + 12: cbNrTheads.ItemIndex := 11; end; end; @@ -418,6 +431,7 @@ procedure TOptionsForm.FormShow(Sender: TObject); cbUseTemplate.Checked := AlwaysCreateBlankFlame; cbMissingPlugin.Checked := WarnOnMissingPlugin; cbEmbedThumbs.Checked := EmbedThumbnails; + //cbSinglePrecision.Checked := SingleBuffer; rgRotationMode.ItemIndex := MainForm_RotationMode; if PreserveQuality then @@ -538,7 +552,14 @@ procedure TOptionsForm.FormShow(Sender: TObject); cbGLClick(nil); txtChaotica.Text := ChaoticaPath; txtChaotica64.Text := ChaoticaPath64; + + {$ifdef Apo7X64} + cbc64.Checked := true; + {$else} cbC64.Checked := UseX64IfPossible; + {$endif} + + txtPluginFolder.Text := PluginPath; UpdateShapeColors; @@ -609,6 +630,7 @@ procedure TOptionsForm.btnOKClick(Sender: TObject); EmbedThumbnails := cbEmbedThumbs.Checked; WarnOnMissingPlugin := cbMissingPlugin.Checked; LanguageFile := AvailableLanguages.Strings[txtLanguageFile.ItemIndex]; + //SingleBuffer := cbSinglePrecision.Checked; MainForm_RotationMode := rgRotationMode.ItemIndex; PreserveQuality := (rgZoomingMode.ItemIndex = 0); @@ -717,17 +739,28 @@ procedure TOptionsForm.btnOKClick(Sender: TObject); HelpPath := txtHelp.Text; ChaoticaPath := txtChaotica.text; ChaoticaPath64 := txtChaotica64.text; + + {$ifdef Apo7X64} + {$else} UseX64IfPossible := cbC64.Checked; + PluginPath := txtPluginFolder.Text; + if (RightStr(PluginPath, 1) <> '\') then + PluginPath := PluginPath + '\'; + {$endif} AutoSaveEnabled := cbEnableAutosave.Checked; AutoSavePath := txtDefaultSaveFile.Text; AutoSaveFreq := cbFreq.ItemIndex; + + + MainForm.mnuExportFLame.Enabled := FileExists(flam3Path); - MainForm.mnuExportChaotica.Enabled := FileExists(chaoticaPath); + //MainForm.mnuExportChaotica.Enabled := FileExists(chaoticaPath); + MainForm.mnuExportChaotica.Enabled := FileExists(chaoticaPath + '\32bit\chaotica.exe'); if (warn) then - Application.MessageBox(PAnsiChar(TextByKey('options-restartnotice')), PAnsiChar('Apophysis'), MB_ICONWARNING); + Application.MessageBox(PChar(TextByKey('options-restartnotice')), PChar('Apophysis'), MB_ICONWARNING); Close; end; @@ -948,8 +981,9 @@ procedure TOptionsForm.FormCreate(Sender: TObject); Panel24.Caption := TextByKey('common-maximum'); Panel27.Caption := TextByKey('common-maximum'); Label49.Caption := TextByKey('common-minutes'); - Panel47.Caption := TextByKey('common-filename') + ' (x86)'; - Panel49.Caption := TextByKey('common-filename') + ' (x64)'; + Panel47.Caption := TextByKey('common-filename'); + Panel50.Caption := TextByKey('options-tab-general-pluginpath'); + //Panel49.Caption := TextByKey('common-filename') + ' (x64)'; Panel48.Caption := TextByKey('options-tab-editor-previewtransparency'); cbC64.Caption := textbykey('options-tab-environment-usex64chaotica'); chkEnableEditorPreview.Caption := TextByKey('options-tab-editor-enablepreview'); @@ -1055,7 +1089,18 @@ procedure TOptionsForm.FormCreate(Sender: TObject); chkRememberLastOpen.Caption := TextByKey('options-tab-environment-rememberlastopen'); cbEnableAutosave.Caption := TextByKey('options-tab-environment-autosave'); panel45.Caption := TextByKey('options-tab-environment-savefrequency'); - + cbSinglePrecision.Caption := TextByKey('options-tab-general-singleprecision'); + grpEditorColors.Caption := TextByKey('editor-tab-color-title'); + + {$ifdef Apo7X64} + Panel50.Enabled := false; + btnPluginPath.Enabled := false; + txtPluginFolder.Enabled := false; + Panel50.Font.Color := clGrayText; + cbc64.Enabled := false; + cbc64.Font.Color := clGrayText; + {$endif} + for i:= 0 to NRVAR - 1 do begin clbVarEnabled.AddItem(varnames(i),nil); end; @@ -1174,6 +1219,28 @@ procedure TOptionsForm.btnPlayClick(Sender: TObject); sndPlaySound(pchar(SND_ALIAS_SYSTEMASTERISK), SND_ALIAS_ID or SND_NOSTOP or SND_ASYNC); end; +procedure TOptionsForm.btnPluginPathClick(Sender: TObject); +var + TitleName : string; + lpItemID : PItemIDList; + BrowseInfo : TBrowseInfo; + DisplayName : array[0..MAX_PATH] of char; + TempPath : array[0..MAX_PATH] of char; +begin + FillChar(BrowseInfo, sizeof(TBrowseInfo), #0); + BrowseInfo.hwndOwner := self.Handle; + BrowseInfo.pszDisplayName := @DisplayName; + TitleName := 'Please specify the plugin folder'; + BrowseInfo.lpszTitle := PChar(TitleName); + BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS; + lpItemID := SHBrowseForFolder(BrowseInfo); + if lpItemId <> nil then begin + SHGetPathFromIDList(lpItemID, TempPath); + txtPluginFolder.Text := TempPath; + GlobalFreePtr(lpItemID); + end; +end; + procedure TOptionsForm.btnGradientsFileClick(Sender: TObject); var fn:string; @@ -1327,9 +1394,9 @@ procedure TOptionsForm.SpeedButton1Click(Sender: TObject); LanguageInfo(fn, s1, s2); if s1 <> '' then begin if not DirectoryExists(ExtractFilePath(Application.ExeName) + 'Languages\') then - CreateDirectory(PAnsiChar(ExtractFilePath(Application.ExeName) + 'Languages\'), nil); + CreateDirectory(PChar(ExtractFilePath(Application.ExeName) + 'Languages\'), nil); if (lowercase(ExtractFilePath(fn)) <> lowercase(ExtractFilePath(Application.ExeName) + 'Languages\')) then - CopyFile(PAnsiChar(fn), PAnsiChar(fn2), False); + CopyFile(PChar(fn), PChar(fn2), False); AvailableLanguages.Add(fn2); i := AvailableLanguages.Count - 1; if (s2 <> '') then @@ -1337,7 +1404,7 @@ procedure TOptionsForm.SpeedButton1Click(Sender: TObject); txtLanguageFile.Items.Add(s1); txtLanguageFile.ItemIndex := txtLanguageFile.Items.Count - 1; end else begin - Application.MessageBox(PAnsichar(TextByKey('common-invalidformat')), PAnsiChar('Apophysis'), MB_ICONERROR); + Application.MessageBox(PChar(TextByKey('common-invalidformat')), PChar('Apophysis'), MB_ICONERROR); end; end; end; @@ -1345,7 +1412,29 @@ procedure TOptionsForm.SpeedButton1Click(Sender: TObject); procedure TOptionsForm.btnChaoticaClick(Sender: TObject); var fn: string; begin - OpenDialog.Filter := TextBykey('common-filter-allfiles') + '|*.*'; + + // new b. 1550 + fn := ChaoticaPath; + if SelectDirectory(fn, [sdAllowCreate, sdPerformCreate, sdPrompt], 0) then + begin + txtChaotica.Text := fn; + if not FileExists(fn + '\32bit\chaotica.exe') then + begin + MessageBox(0, + PCHAR('Could not find "' + fn + '\32bit\chaotica.exe" - invalid Chaotica 0.45+ path'), + PCHAR('Apophysis 7X'), MB_ICONHAND or MB_OK); + txtChaotica.Text := ChaoticaPath; + fn := ChaoticaPath; + end; + + if not FileExists(fn + '\64bit\chaotica.exe') then + begin + cbc64.Enabled := false; + cbc64.Checked := false; + end; + end; + + {OpenDialog.Filter := TextBykey('common-filter-allfiles') + '|*.*'; if sender = TSpeedButton(btnChaotica) then OpenDialog.InitialDir := ExtractFilePath(ChaoticaPath) else @@ -1356,7 +1445,9 @@ procedure TOptionsForm.btnChaoticaClick(Sender: TObject); begin if sender = TSpeedButton(btnChaotica) then txtChaotica.text := fn else txtChaotica64.text := fn; - end; + end; } + + end; procedure TOptionsForm.chkEnableEditorPreviewClick(Sender: TObject); diff --git a/Source/Forms/Preview.ddp b/Source/Forms/Preview.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/Preview.ddp and /dev/null differ diff --git a/Source/Forms/Preview.dfm b/Source/Forms/Preview.dfm index 00aad99..3fd315b 100644 --- a/Source/Forms/Preview.dfm +++ b/Source/Forms/Preview.dfm @@ -23,7 +23,7 @@ object PreviewForm: TPreviewForm Left = 0 Top = 0 Width = 204 - Height = 157 + Height = 152 Align = alClient BevelInner = bvLowered BevelOuter = bvLowered diff --git a/Source/Forms/Preview.pas b/Source/Forms/Preview.pas index 0483030..0e01dd3 100644 --- a/Source/Forms/Preview.pas +++ b/Source/Forms/Preview.pas @@ -26,7 +26,7 @@ interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - ExtCtrls, ControlPoint, Render, Translation; + ExtCtrls, ControlPoint, RenderingInterface, Translation; type TPreviewForm = class(TForm) diff --git a/Source/Forms/Save.ddp b/Source/Forms/Save.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/Save.ddp and /dev/null differ diff --git a/Source/Forms/Save.dfm b/Source/Forms/Save.dfm index 6f55b5e..ecb1bcd 100644 --- a/Source/Forms/Save.dfm +++ b/Source/Forms/Save.dfm @@ -3,12 +3,12 @@ object SaveForm: TSaveForm Top = 432 BorderStyle = bsDialog Caption = 'Save Parameters' - ClientHeight = 124 - ClientWidth = 420 + ClientHeight = 153 + ClientWidth = 517 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -14 Font.Name = 'MS Sans Serif' Font.Style = [] OldCreateOrder = False @@ -16,21 +16,21 @@ object SaveForm: TSaveForm OnCreate = FormCreate OnShow = FormShow DesignSize = ( - 420 - 124) - PixelsPerInch = 96 - TextHeight = 13 + 517 + 153) + PixelsPerInch = 120 + TextHeight = 16 object btnDefGradient: TSpeedButton - Left = 390 - Top = 7 - Width = 24 - Height = 24 + Left = 480 + Top = 9 + Width = 30 + Height = 29 Hint = 'Browse...' Anchors = [akTop, akRight] Flat = True Font.Charset = ANSI_CHARSET Font.Color = clWindowText - Font.Height = -11 + Font.Height = -15 Font.Name = 'Arial' Font.Style = [fsBold] Glyph.Data = { @@ -66,10 +66,10 @@ object SaveForm: TSaveForm OnClick = btnDefGradientClick end object btnSave: TButton - Left = 262 - Top = 94 - Width = 75 - Height = 25 + Left = 322 + Top = 116 + Width = 93 + Height = 30 Anchors = [akRight, akBottom] Caption = '&Save' Default = True @@ -77,20 +77,20 @@ object SaveForm: TSaveForm OnClick = btnSaveClick end object btnCancel: TButton - Left = 342 - Top = 94 - Width = 75 - Height = 25 + Left = 421 + Top = 116 + Width = 92 + Height = 30 Anchors = [akRight, akBottom] Caption = 'Cancel' TabOrder = 3 OnClick = btnCancelClick end object pnlTarget: TPanel - Left = 8 - Top = 8 - Width = 101 - Height = 21 + Left = 10 + Top = 10 + Width = 124 + Height = 26 Cursor = crArrow BevelOuter = bvLowered Caption = 'Destination' @@ -99,10 +99,10 @@ object SaveForm: TSaveForm TabOrder = 4 end object pnlName: TPanel - Left = 8 - Top = 32 - Width = 101 - Height = 21 + Left = 10 + Top = 39 + Width = 124 + Height = 26 Cursor = crArrow BevelOuter = bvLowered Caption = 'Name' @@ -111,28 +111,28 @@ object SaveForm: TSaveForm TabOrder = 5 end object txtFilename: TEdit - Left = 104 - Top = 8 - Width = 287 - Height = 21 + Left = 128 + Top = 10 + Width = 353 + Height = 24 Anchors = [akLeft, akTop, akRight] TabOrder = 0 Text = 'txtFilename' end object txtTitle: TEdit - Left = 104 - Top = 32 - Width = 311 - Height = 21 + Left = 128 + Top = 39 + Width = 383 + Height = 24 Anchors = [akLeft, akTop, akRight] TabOrder = 1 Text = 'txtTitle' end object optUseOldFormat: TRadioButton - Left = 8 - Top = 64 - Width = 247 - Height = 17 + Left = 10 + Top = 79 + Width = 304 + Height = 21 Anchors = [akLeft, akTop, akRight] Caption = 'Use classic flame format' Checked = True @@ -140,10 +140,10 @@ object SaveForm: TSaveForm TabStop = True end object optUseNewFormat: TRadioButton - Left = 8 - Top = 82 - Width = 247 - Height = 17 + Left = 10 + Top = 101 + Width = 304 + Height = 21 Anchors = [akLeft, akTop, akRight] Caption = 'Use new flame format' Enabled = False diff --git a/Source/Forms/Save.pas b/Source/Forms/Save.pas index cbc41b0..6018475 100644 --- a/Source/Forms/Save.pas +++ b/Source/Forms/Save.pas @@ -185,9 +185,9 @@ procedure TSaveForm.FormShow(Sender: TObject); txtTitle.Text := Title; //btnSave.SetFocus; self.Caption := TextByKey(SaveTypeTextKey(SaveType)); - if (SaveType = stSaveParameters) or (SaveType = stSaveAllParameters) then + {if (SaveType = stSaveParameters) or (SaveType = stSaveAllParameters) then self.Height := 160 - else self.Height := 120; + else self.Height := 120; } if (SaveType = stSaveAllParameters) then txtTitle.Text := ''; txtTitle.Enabled := (SaveType = stSaveParameters) or (SaveType = stExportUPR) or (SaveType = stSaveGradient); diff --git a/Source/Forms/SavePreset.ddp b/Source/Forms/SavePreset.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/SavePreset.ddp and /dev/null differ diff --git a/Source/Forms/ScriptForm.ddp b/Source/Forms/ScriptForm.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/ScriptForm.ddp and /dev/null differ diff --git a/Source/Forms/ScriptForm.dfm b/Source/Forms/ScriptForm.dfm index 056b124..db775d8 100644 --- a/Source/Forms/ScriptForm.dfm +++ b/Source/Forms/ScriptForm.dfm @@ -1,9 +1,9 @@ object ScriptEditor: TScriptEditor Left = 312 Top = 383 - Width = 591 - Height = 512 Caption = 'Script Editor' + ClientHeight = 485 + ClientWidth = 583 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText @@ -71,7 +71,6 @@ object ScriptEditor: TScriptEditor Align = alRight AutoSize = True Caption = 'ToolBar' - Flat = True Images = MainForm.Buttons ParentShowHint = False ShowHint = True @@ -165,6 +164,7 @@ object ScriptEditor: TScriptEditor AutoCompletion.Font.Name = 'MS Sans Serif' AutoCompletion.Font.Style = [] AutoCompletion.Height = 120 + AutoCompletion.StartToken = '(.' AutoCompletion.Width = 400 AutoCorrect.Active = True AutoHintParameterPosition = hpBelowCode @@ -173,6 +173,7 @@ object ScriptEditor: TScriptEditor BlockLineColor = clGray BkColor = clWindow BorderStyle = bsNone + ClipboardFormats = [cfText] CodeFolding.Enabled = False CodeFolding.LineColor = clGray Ctl3D = False @@ -214,18 +215,17 @@ object ScriptEditor: TScriptEditor SelBkColor = clHighlight ShowRightMargin = True SmartTabs = False - SyntaxStyles = PascalStyler + SyntaxStyles = Styler TabOrder = 0 TabSize = 4 TabStop = True TrimTrailingSpaces = False - UndoLimit = 100 UrlAware = False UrlStyle.TextColor = clBlue UrlStyle.BkColor = clWhite UrlStyle.Style = [fsUnderline] UseStyler = True - Version = '2.1.7.6' + Version = '2.3.7.6' WordWrap = wwNone OnChange = EditorChange end @@ -245,20 +245,20 @@ object ScriptEditor: TScriptEditor DefaultExt = 'asc' Filter = 'Apophysis Script Files (*.asc)|*.asc|Text files (*.txt)|*.txt' Options = [ofHideReadOnly, ofFileMustExist, ofEnableSizing] - Left = 456 - Top = 32 + Left = 472 + Top = 64 end object MainSaveDialog: TSaveDialog DefaultExt = 'asc' Filter = 'Apophysis Script Files (*.asc)|*.asc|Text files (*.txt)|*.txt' Options = [ofOverwritePrompt, ofHideReadOnly, ofEnableSizing] - Left = 424 + Left = 344 Top = 32 end object PopupMenu: TPopupMenu Images = MainForm.Buttons - Left = 392 - Top = 32 + Left = 280 + Top = 112 object mnuUndo: TMenuItem Caption = 'Undo' ImageIndex = 4 @@ -284,58 +284,139 @@ object ScriptEditor: TScriptEditor OnClick = mnuPasteClick end end - object PascalStyler: TAdvPascalMemoStyler - BlockStart = 'begin' + object Scripter: TatPascalScripter + SourceCode.Strings = ( + '') + SaveCompiledCode = False + EventSupport = False + OnCompileError = ScripterCompileError + ShortBooleanEval = False + LibOptions.SearchPath.Strings = ( + '$(CURDIR)' + '$(APPDIR)') + LibOptions.SourceFileExt = '.psc' + LibOptions.CompiledFileExt = '.pcu' + LibOptions.UseScriptFiles = False + CallExecHookEvent = False + Left = 480 + Top = 200 + end + object OpenDialog: TOpenDialog + DefaultExt = 'fla' + Filter = + 'Flame files (*.flame)|*.flame|Apophysis 1.0 parameters (*.apo;*.' + + 'fla)|*.apo;*.fla|All files (*.*)|*.*' + Options = [ofHideReadOnly, ofFileMustExist, ofEnableSizing] + Left = 416 + Top = 200 + end + object SaveDialog: TSaveDialog + DefaultExt = 'flame' + Filter = 'Flame files (*.flame)|*.flame' + Options = [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofEnableSizing] + Left = 440 + Top = 128 + end + object Styler: TAdvPascalMemoStyler + BlockStart = 'begin,try,case,class,record' BlockEnd = 'end' LineComment = '//' MultiCommentLeft = '{' MultiCommentRight = '}' CommentStyle.TextColor = clNavy - CommentStyle.BkColor = clWindow + CommentStyle.BkColor = clWhite CommentStyle.Style = [fsItalic] - NumberStyle.TextColor = clNavy - NumberStyle.BkColor = clWindow - NumberStyle.Style = [] + NumberStyle.TextColor = clFuchsia + NumberStyle.BkColor = clWhite + NumberStyle.Style = [fsBold] AllStyles = < item KeyWords.Strings = ( + 'absolute' + 'abstract' 'and' + 'array' + 'as' + 'asm' + 'assembler' + 'automated' 'begin' 'break' + 'case' + 'cdecl' 'class' 'class' 'const' 'constructor' 'continue' 'default' + 'deprecated' 'destructor' + 'dispid' + 'dispinterface' + 'div' 'do' + 'downto' + 'dynamic' 'else' 'end' 'except' + 'exports' + 'external' + 'far' + 'file' 'finalise' 'finally' 'for' + 'forward' 'function' 'if' 'implementation' + 'in' 'inherited' 'initialise' + 'inline' 'interface' + 'is' + 'label' + 'library' + 'message' + 'mod' + 'near' 'nil' 'not' + 'object' + 'of' 'or' + 'out' + 'overload' 'override' + 'packed' + 'pascal' + 'platform' 'private' 'procedure' + 'program' + 'program' 'property' 'protected' 'public' 'published' 'raise' + 'record' + 'register' + 'reintroduce' 'repeat' + 'resourcestring' + 'safecall' + 'set' + 'shl' + 'shr' + 'stdcall' 'stored' + 'string' 'then' + 'threadvar' 'to' 'try' 'type' @@ -345,13 +426,14 @@ object ScriptEditor: TScriptEditor 'var' 'virtual' 'while' - 'with') + 'with' + 'xor') Font.Charset = DEFAULT_CHARSET - Font.Color = clBlack + Font.Color = clGreen Font.Height = -11 Font.Name = 'Courier New' Font.Style = [fsBold] - BGColor = clWindow + BGColor = clWhite StyleType = stKeyword BracketStart = #0 BracketEnd = #0 @@ -359,231 +441,44 @@ object ScriptEditor: TScriptEditor end item Font.Charset = DEFAULT_CHARSET - Font.Color = clBlack + Font.Color = clBlue Font.Height = -11 Font.Name = 'Courier New' Font.Style = [] - BGColor = clWindow + BGColor = clWhite StyleType = stBracket - BracketStart = #0 - BracketEnd = #0 + BracketStart = #39 + BracketEnd = #39 Info = 'Simple Quote' end item Font.Charset = DEFAULT_CHARSET - Font.Color = clBlack + Font.Color = clBlue Font.Height = -11 Font.Name = 'Courier New' Font.Style = [] - BGColor = clWindowText + BGColor = clWhite StyleType = stBracket - BracketStart = #0 - BracketEnd = #0 + BracketStart = '"' + BracketEnd = '"' Info = 'Double Quote' end item Font.Charset = DEFAULT_CHARSET - Font.Color = clTeal + Font.Color = clRed Font.Height = -11 Font.Name = 'Courier New' Font.Style = [] - BGColor = clWindow + BGColor = clWhite StyleType = stSymbol BracketStart = #0 BracketEnd = #0 - Symbols = ' ,;:.(){}[]=-*/^%<>#'#13#10 + Symbols = ' ,;:.(){}[]=+-*/^%<>#'#13#10 Info = 'Symbols Delimiters' end> AutoCompletion.Strings = ( 'ShowMessage' - 'InputQuery' - '' - 'RotateFlame' - 'RotateReference' - 'Rotate' - 'Multiply' - 'StoreFlame' - 'GetFlame' - 'LoadFlame' - 'Scale' - 'Translate' - 'ActiveTransform' - 'SetActiveTransform' - 'Transforms' - 'FileCount' - 'AddTransform' - 'DeleteTransform' - 'CopyTransform' - 'Clear' - 'Preview' - 'Render' - 'Print' - 'AddSymmetry' - 'Morph' - 'SetRenderBounds' - 'SetFlameFile' - 'ListFile' - 'SaveFlame' - 'GetFileName' - 'ShowStatus' - 'RandomFlame' - 'RandomGradient' - 'SaveGradient' - 'Variation' - 'SetVariation' - 'ProgramVersionString' - 'VariationIndex' - 'VariationName' - 'CalculateScale' - 'CalculateBounds' - 'NormalizeVars' - 'GetSaveFileName' - 'CopyFile' - '' - 'Renderer' - '' - 'Filename' - 'Width' - 'Height' - 'MaxMemory' - '' - 'Flame' - '' - 'Gamma' - 'Brightness' - 'Vibrancy' - 'Time' - 'Zoom' - 'Width' - 'Height' - 'SampleDensity' - 'Quality' - 'Oversample' - 'FilterRadius' - 'Scale' - 'Gradient' - 'Background' - 'Name' - 'Batches' - 'FinalXformEnabled' - '' - 'Transform' - '' - 'coefs' - 'post' - 'Color' - 'Weight' - 'Symmetry' - 'Clear' - 'Rotate' - 'Scale' - 'RotateOrigin' - 'Variation' - '' - 'Options' - '' - 'JPEGQuality' - 'BatchSize' - 'ParameterFile' - 'SmoothPaletteFile' - 'NumTries' - 'TryLength' - 'ConfirmDelete' - 'FixedReference' - 'SampleDensity' - 'Gamma' - 'Brightness' - 'Vibrancy' - 'Oversample' - 'FilterRadius' - 'Transparency' - 'PreviewLowQuality' - 'PreviewMediumQuality' - 'PreviewHighQuality' - 'MinTransforms' - 'MaxTransforms' - 'MutateMinTransforms' - 'MutateMaxTransforms' - 'RandomPrefix' - 'KeepBackground' - 'SymmetryType' - 'SymmetryOrder' - 'Variations' - 'GradientOnRandom' - 'MinNodes' - 'MaxNodes' - 'MinHue' - 'MaxHue' - 'MinSaturation' - 'MaxSaturation' - 'MinLuminance' - 'MaxLuminance' - 'UPRSampleDensity' - 'UPRFilterRadius' - 'UPROversample' - 'UPRAdjustDensity' - 'UPRColoringIdent' - 'UPRColoringFile' - 'UPRFormulaFile' - 'UPRFormulaIdent' - 'UPRWidth' - 'UPRHeight' - 'ExportRenderer' - '' - 'Pivot' - '' - 'Mode' - 'Set' - 'Reset' - '' - 'PI' - 'NVARS' - 'NXFORMS' - 'INSTALLPATH' - 'SYM_NONE' - 'SYM_BILATERAL' - 'SYM_ROTATIONAL' - '' - 'V_LINEAR' - 'V_SINUSOIDAL' - 'V_SPHERICAL' - 'V_SWIRL' - 'V_HORSESHOE' - 'V_POLAR' - 'V_HANDKERCHIEF' - 'V_HEART' - 'V_DISC' - 'V_SPIRAL' - 'V_HYPERBOLIC' - 'V_DIAMOND' - 'V_EX' - 'V_JULIA' - 'V_BENT' - 'V_WAVES' - 'V_FISHEYE' - 'V_POPCORN' - 'V_EXPONENTIAL' - 'V_POWER' - 'V_COSINE' - 'V_RINGS' - 'V_FAN' - 'V_EYEFISH' - 'V_BUBBLE' - 'V_CYLINDER' - 'V_NOISE' - 'V_BLUR' - 'V_GAUSSIANBLUR' - 'V_RADIALBLUR' - 'V_RINGS2' - 'V_FAN2' - 'V_BLOB' - 'V_PDJ' - 'V_PERSPECTIVE' - 'V_JULIAN' - 'V_JULIASCOPE' - 'V_CURL' - 'V_RANDOM' - '') + 'MessageDlg') HintParameter.TextColor = clBlack HintParameter.BkColor = clInfoBk HintParameter.HintCharStart = '(' @@ -593,34 +488,8 @@ object ScriptEditor: TScriptEditor HintParameter.Parameters.Strings = ( 'ShowMessage(const Msg: string);' - 'InputQuery(const Caption: string; const Prompt: string; var Valu' + - 'e: string)' - 'DeleteFile(const filename: string)' - 'RotateFlame(Angle: double)' - 'RotateReference(Angle: double)' - 'Rotate(Angle: double)' - 'Multiply(a00: double, a01: double, a10: double, a11: double)' - 'StoreFlame(FlameNumber: integer)' - 'GetFlame(FlameNumber: integer)' - 'LoadFlame(FlameNumber: integer)' - 'Scale(Scale: double)' - 'Translate(X: double, Y: double)' - 'SetActiveTransform(TransformNumber: integer)' - 'Print(something_printable)' - 'AddSymmetry(symmetry_type: integer)' - - 'Morph(FlameNumber1: integer, FlameNumber2: integer, Time: double' + - ')' - 'SetFlameFile(const filename: string)' - 'ListFile(const filename: string)' - 'SaveFlame(const filename: string)' - 'ShowStatus(const Text: string)' - 'RandomFlame(randomness_type: integer)' - 'SaveGradient(Title: string, FileName: string)' - 'SetVariation(Number: integer)' - 'VariationIndex(var_name: string): integer' - 'VariationName(var_index: integer): string' - 'CopyFile(Source: string, Destination: string)') + 'MessageDlg(const Msg: string; DlgType: TMsgDlgType; Buttons: TMs' + + 'gDlgButtons; HelpCtx: Longint): Integer);') HexIdentifier = '$' Description = 'Pascal' Filter = 'Pascal Files (*.pas,*.dpr,*.dpk,*.inc)|*.pas;*.dpr;*.dpk;*.inc' @@ -635,6 +504,20 @@ object ScriptEditor: TScriptEditor RegionType = rtClosed ShowComments = False end + item + Identifier = 'constructor' + RegionStart = 'begin' + RegionEnd = 'end' + RegionType = rtClosed + ShowComments = False + end + item + Identifier = 'destructor' + RegionStart = 'begin' + RegionEnd = 'end' + RegionType = rtClosed + ShowComments = False + end item Identifier = 'interface' RegionStart = 'interface' @@ -681,49 +564,7 @@ object ScriptEditor: TScriptEditor RegionType = rtClosed ShowComments = False end> - Left = 328 - Top = 32 - end - object Scripter: TatPascalScripter - SourceCode.Strings = ( - '') - SaveCompiledCode = False - EventSupport = False - OnCompileError = ScripterCompileError - ShortBooleanEval = False - LibOptions.SearchPath.Strings = ( - '$(CURDIR)' - '$(APPDIR)') - LibOptions.SourceFileExt = '.psc' - LibOptions.CompiledFileExt = '.pcu' - LibOptions.UseScriptFiles = False - CallExecHookEvent = False - Left = 360 - Top = 32 - end - object OpenDialog: TOpenDialog - DefaultExt = 'fla' - Filter = - 'Flame files (*.flame)|*.flame|Apophysis 1.0 parameters (*.apo;*.' + - 'fla)|*.apo;*.fla|All files (*.*)|*.*' - Options = [ofHideReadOnly, ofFileMustExist, ofEnableSizing] - Left = 328 - Top = 64 - end - object SaveDialog: TSaveDialog - DefaultExt = 'flame' - Filter = 'Flame files (*.flame)|*.flame' - Options = [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofEnableSizing] - Left = 360 - Top = 64 - end - object F2SXML: TXmlScanner - Normalize = True - OnStartTag = F2SXMLStartTag - OnEmptyTag = F2SXMLEmptyTag - OnEndTag = F2SXMLEndTag - OnContent = F2SXMLContent - Left = 392 - Top = 64 + Left = 288 + Top = 208 end end diff --git a/Source/Forms/ScriptForm.pas b/Source/Forms/ScriptForm.pas index 14c876a..cd99355 100644 --- a/Source/Forms/ScriptForm.pas +++ b/Source/Forms/ScriptForm.pas @@ -27,8 +27,8 @@ interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, ControlPoint, Buttons, ComCtrls, ToolWin, Menus, - atScript, atPascal, AdvMemo, Advmps, XFormMan, XForm, GradientHlpr, cmap, - LibXmlParser, LibXmlComps, Math, Translation; + XFormMan, XForm, GradientHlpr, cmap,LibXmlParser, LibXmlComps, Math, Translation, + atScript, atPascal, AdvMemo, Advmps; const NCPS = 10; @@ -85,7 +85,6 @@ TScriptEditor = class(TForm) N1: TMenuItem; BackPanel: TPanel; Editor: TAdvMemo; - PascalStyler: TAdvPascalMemoStyler; Scripter: TatPascalScripter; Splitter1: TSplitter; Console: TMemo; @@ -93,7 +92,7 @@ TScriptEditor = class(TForm) btnBreak: TToolButton; OpenDialog: TOpenDialog; SaveDialog: TSaveDialog; - F2SXML: TXmlScanner; + Styler: TAdvPascalMemoStyler; procedure F2SXMLStartTag(Sender: TObject; TagName: string; Attributes: TAttrList); procedure F2SXMLEndTag(Sender: TObject; TagName: string); @@ -411,7 +410,7 @@ implementation } uses Main, Editor, Adjust, Global, Mutate, Registry, Preview, - ScriptRender, ap_math, ap_classes, ap_sysutils, + ScriptRender, ap_math, ap_classes, ap_sysutils, ap_Dialogs, SavePreset, ap_windows, ap_FileCtrl(*, bmdll32*); {$R *.DFM} @@ -480,14 +479,21 @@ TOperationLibrary = class(TatScripterLibrary) end; procedure TScriptEditor.ScriptFromFlame(flameXML:string); -var i : integer; +var i : integer; xml : TXmlScanner; begin // Clear & Set caption to "New Script" btnNewClick(btnNew); chaosLines := TStringList.Create; - F2SXML.LoadFromBuffer(PCHAR(flameXML)); - F2SXML.Execute; + xml := TXmlScanner.Create(nil); + xml.Normalize := True; + xml.OnContent := F2SXMLContent; + xml.OnEmptyTag := F2SXMLEmptyTag; + xml.OnEndTag := F2SXMLEndTag; + xml.OnStartTag := F2SXMLStartTag; + xml.LoadFromBuffer(PANSICHAR(AnsiString(flameXML))); + xml.Execute; + xml.Destroy; // use chaosLines... for i := 0 to chaosLines.Count - 1 do @@ -1641,7 +1647,7 @@ procedure LoadXMLFlame(index: integer); begin if Pos('', FStrings[i]) <> 0; - MainForm.ParseXML(ScriptEditor.Cp, PCHAR(IFSStrings.Text), true); + MainForm.ParseXML(ScriptEditor.Cp, IFSStrings.Text, true); for i := 0 to NXFORMS - 1 do if ScriptEditor.cp.xform[i].density = 0 then break; NumTransforms := i; @@ -3732,7 +3738,7 @@ procedure TScriptEditor.FillFileList; if (p <> 0) then begin pname := ''; - MainForm.ListXMLScanner.LoadFromBuffer(PCHAR(FSTrings[i])); + MainForm.ListXMLScanner.LoadFromBuffer(PANSICHAR(AnsiString(FSTrings[i]))); MainForm.ListXMLScanner.Execute; if Trim(pname) = '' then Title := '*untitled ' + ptime @@ -3958,7 +3964,7 @@ procedure TScriptEditor.btnFavoriteClick(Sender: TObject); There := true; if there then exit; Favorites.Add(Script); - Favorites.SaveToFile(AppPath + scriptFavsFilename); + Favorites.SaveToFile(GetEnvVarValue('APPDATA') + '\' + scriptFavsFilename); end; procedure TScriptEditor.FormShortCut(var Msg: TWMKey; var Handled: Boolean); @@ -3991,7 +3997,7 @@ procedure TScriptEditor.F2SXMLEmptyTag(Sender: TObject; TagName: string; Attributes: TAttrList); var i: integer; - v,w: string; + v,w: TStringType; d, floatcolor: double; Tokens: TStringList; begin @@ -4002,13 +4008,14 @@ procedure TScriptEditor.F2SXMLEmptyTag(Sender: TObject; TagName: string; Editor.Lines.Add(''); if TagName = 'finalxform' then begin Editor.Lines.Add('{ Final Transform }'); + Editor.Lines.Add('Flame.FinalXformEnabled := True;'); Editor.Lines.Add('SetActiveTransform(transforms);'); end else begin - w := '{ Transform ' + IntToStr(AddedXForms + 1); + w := TStringType('{ Transform ' + IntToStr(AddedXForms + 1)); v := Attributes.Value('name'); if (v <> '') then w := w + ' (' + v + ')'; w := w + ' }'; - Editor.Lines.Add(w); + Editor.Lines.Add(String(w)); Editor.Lines.Add('AddTransform;'); end; Editor.Lines.Add('with Transform do begin'); @@ -4017,16 +4024,16 @@ procedure TScriptEditor.F2SXMLEmptyTag(Sender: TObject; TagName: string; v := Attributes.Value('weight'); if (v <> '') and (TagName = 'xform') then - Editor.Lines.Add(' Weight := ' + v + ';'); + Editor.Lines.Add(' Weight := ' + String(v) + ';'); v := Attributes.Value('color'); - if (v <> '') then Editor.Lines.Add(' Color := ' + v + ';'); + if (v <> '') then Editor.Lines.Add(' Color := ' + String(v) + ';'); v := Attributes.Value('var_color'); - if (v <> '') then Editor.Lines.Add(' VarColor := ' + v + ';'); + if (v <> '') then Editor.Lines.Add(' VarColor := ' + String(v) + ';'); v := Attributes.Value('symmetry'); - if (v <> '') and (TagName = 'xform') then Editor.Lines.Add(' Symmetry := ' + v + ';'); + if (v <> '') and (TagName = 'xform') then Editor.Lines.Add(' Symmetry := ' + String(v) + ';'); v := Attributes.Value('coefs'); if (v <> '') then begin - GetTokens(v, tokens); + GetTokens(String(v), tokens); Editor.Lines.Add(' a := ' + Tokens[0] + ';'); Editor.Lines.Add(' b := ' + Tokens[2] + ';'); Editor.Lines.Add(' c := ' + Tokens[1] + ';'); @@ -4037,7 +4044,7 @@ procedure TScriptEditor.F2SXMLEmptyTag(Sender: TObject; TagName: string; v := Attributes.Value('post'); if v <> '' then begin - GetTokens(v, tokens); + GetTokens(String(v), tokens); Editor.Lines.Add(' post[0,0] := ' + Tokens[0] + ';'); Editor.Lines.Add(' post[0,1] := (-1) * ' + Tokens[1] + ';'); Editor.Lines.Add(' post[1,0] := (-1) * ' + Tokens[2] + ';'); @@ -4053,7 +4060,7 @@ procedure TScriptEditor.F2SXMLEmptyTag(Sender: TObject; TagName: string; chaosLines.Add('{ Weight modifiers for transform ' + IntToStr(AddedXForms + 1) + ' }'); chaosLines.Add('SetActiveTransform(' + IntToStr(AddedXForms) + ');'); chaosLines.Add('with Transform do begin'); - GetTokens(v, tokens); + GetTokens(String(v), tokens); for i := 0 to Tokens.Count-1 do chaosLines.Add(' chaos[' + IntToStr(i) + '] := ' + Tokens[i]) ; chaosLines.Add('end;'); @@ -4061,20 +4068,20 @@ procedure TScriptEditor.F2SXMLEmptyTag(Sender: TObject; TagName: string; v := Attributes.Value('opacity'); if v <> '' then begin - Editor.Lines.Add(' Opacity := ' + v); + Editor.Lines.Add(' Opacity := ' + String(v)); end; for i := 0 to NRVAR - 1 do begin - v := Attributes.Value(varnames(i)); + v := Attributes.Value(TStringType(varnames(i))); if v <> '' then - Editor.Lines.Add(' ' + varnames(i) + ' := ' + v); + Editor.Lines.Add(' ' + varnames(i) + ' := ' + String(v)); end; for i := 0 to GetNrVariableNames - 1 do begin - v := Attributes.Value(GetVariableNameAt(i)); + v := Attributes.Value(TStringType(GetVariableNameAt(i))); if v <> '' then begin - Editor.Lines.Add(' ' + GetVariableNameAt(i) + ' := ' + v); + Editor.Lines.Add(' ' + GetVariableNameAt(i) + ' := ' + String(v)); end; end; @@ -4094,7 +4101,7 @@ procedure TScriptEditor.F2SXMLStartTag(Sender: TObject; TagName: string; Attributes: TAttrList); var Tokens: TStringList; - v: string; + v: TStringType; f, b: double; begin Tokens := TStringList.Create; @@ -4109,9 +4116,9 @@ procedure TScriptEditor.F2SXMLStartTag(Sender: TObject; TagName: string; Editor.Lines.Add(' AngleTransform := 180 / PI else AngleTransform := 1;'); Editor.Lines.Add('with Flame do begin'); - v := Attributes.Value('size'); + v := Attributes.Value(TStringType('size')); if (v <> '') then begin - GetTokens(v, tokens); + GetTokens(String(v), tokens); Editor.Lines.Add(' Width := ' + Tokens[0] + ';'); Editor.Lines.Add(' Height := ' + Tokens[1] + ';'); @@ -4120,44 +4127,44 @@ procedure TScriptEditor.F2SXMLStartTag(Sender: TObject; TagName: string; end else f := 0; b := 0; - v := Attributes.Value('brightness'); + v := Attributes.Value(TStringType('brightness')); if (v <> '') then begin - Editor.Lines.Add(' Brightness := ' + v + ';'); - b := StrToFloat(v); + Editor.Lines.Add(' Brightness := ' + String(v) + ';'); + b := StrToFloat(String(v)); end; - v := Attributes.Value('gamma'); - if (v <> '') then Editor.Lines.Add(' Gamma := ' + v + ';'); - v := Attributes.Value('vibrancy'); - if (v <> '') then Editor.Lines.Add(' Vibrancy := ' + v + ';'); - v := Attributes.Value('gamma_threshold'); + v := Attributes.Value(TStringType('gamma')); + if (v <> '') then Editor.Lines.Add(' Gamma := ' + String(v) + ';'); + v := Attributes.Value(TStringType('vibrancy')); + if (v <> '') then Editor.Lines.Add(' Vibrancy := ' + String(v) + ';'); + v := Attributes.Value(TStringType('gamma_threshold')); if (v <> '') then begin - if b <> 0 then b := StrToFloat(v) / b; + if b <> 0 then b := StrToFloat(String(v)) / b; Editor.Lines.Add(' GammaTreshold := ' + FloatToStr(b) + ';'); end; - v := Attributes.Value('zoom'); - if (v <> '') then Editor.Lines.Add(' Zoom := ' + v + ';'); - v := Attributes.Value('scale'); - if (v <> '') then Editor.Lines.Add(' Scale := ' + FloatToStr(StrToFloat(v) * f) + ';'); - v := Attributes.Value('angle'); - if (v <> '') then Editor.Lines.Add(' Angle := ' + v + ';'); + v := Attributes.Value(TStringType('zoom')); + if (v <> '') then Editor.Lines.Add(' Zoom := ' + String(v) + ';'); + v := Attributes.Value(TStringType('scale')); + if (v <> '') then Editor.Lines.Add(' Scale := ' + FloatToStr(StrToFloat(String(v)) * f) + ';'); + v := Attributes.Value(TStringType('angle')); + if (v <> '') then Editor.Lines.Add(' Angle := ' + String(v) + ';'); // 3d - v := Attributes.Value('cam_pitch'); - if (v <> '') then Editor.Lines.Add(' Pitch := ' + v + ' * AngleTransform;'); - v := Attributes.Value('cam_yaw'); - if (v <> '') then Editor.Lines.Add(' Yaw := ' + v + ' * AngleTransform;'); - v := Attributes.Value('cam_perspective'); - if (v <> '') then Editor.Lines.Add(' Perspective := ' + v + ';'); - v := Attributes.Value('cam_zpos'); - if (v <> '') then Editor.Lines.Add(' Z := ' + v + ';'); - v := Attributes.Value('cam_dof'); - if (v <> '') then Editor.Lines.Add(' DOF := ' + v + ';'); + v := Attributes.Value(TStringType('cam_pitch')); + if (v <> '') then Editor.Lines.Add(' Pitch := ' + String(v) + ' * AngleTransform;'); + v := Attributes.Value(TStringType('cam_yaw')); + if (v <> '') then Editor.Lines.Add(' Yaw := ' + String(v) + ' * AngleTransform;'); + v := Attributes.Value(TStringType('cam_perspective')); + if (v <> '') then Editor.Lines.Add(' Perspective := ' + String(v) + ';'); + v := Attributes.Value(TStringType('cam_zpos')); + if (v <> '') then Editor.Lines.Add(' Z := ' + String(v) + ';'); + v := Attributes.Value(TStringType('cam_dof')); + if (v <> '') then Editor.Lines.Add(' DOF := ' + String(v) + ';'); try - v := Attributes.Value('center'); + v := Attributes.Value(TStringType('center')); if (v <> '') then begin - GetTokens(v, tokens); + GetTokens(String(v), tokens); Editor.Lines.Add(' X := ' + Tokens[0] + ';'); Editor.Lines.Add(' Y := ' + Tokens[1] + ';'); end; @@ -4167,9 +4174,9 @@ procedure TScriptEditor.F2SXMLStartTag(Sender: TObject; TagName: string; end; try - v := Attributes.Value('background'); + v := Attributes.Value(TStringType('background')); if (v <> '') then begin - GetTokens(v, tokens); + GetTokens(String(v), tokens); Editor.Lines.Add(' Background[0] := ' + FloatToStr(Floor(StrToFloat(Tokens[0]) * 255)) + ';'); Editor.Lines.Add(' Background[1] := ' + FloatToStr(Floor(StrToFloat(Tokens[1]) * 255)) + ';'); @@ -4181,8 +4188,8 @@ procedure TScriptEditor.F2SXMLStartTag(Sender: TObject; TagName: string; Editor.Lines.Add(' Background[2] := 0' + ';'); end; - v := Attributes.Value('soloxform'); - if (v <> '') then Editor.Lines.Add('SoloXform := ' + v + ';'); + v := Attributes.Value(TStringType('soloxform')); + if (v <> '') then Editor.Lines.Add('SoloXform := ' + String(v) + ';'); Editor.Lines.Add('end;'); end; diff --git a/Source/Forms/ScriptRender.ddp b/Source/Forms/ScriptRender.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/ScriptRender.ddp and /dev/null differ diff --git a/Source/Forms/SplashForm.pas b/Source/Forms/SplashForm.pas index a2841ed..5324215 100644 --- a/Source/Forms/SplashForm.pas +++ b/Source/Forms/SplashForm.pas @@ -27,7 +27,7 @@ implementation procedure TSplashWindow.FormCreate(Sender: TObject); begin - lblVersion.Caption := APP_VERSION; + lblVersion.Caption := APP_VERSION + APP_BUILD; end; procedure TSplashWindow.SetInfo(info:string); diff --git a/Source/Forms/Template.ddp b/Source/Forms/Template.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/Template.ddp and /dev/null differ diff --git a/Source/Forms/Template.pas b/Source/Forms/Template.pas index cc4f4a9..2f964ec 100644 --- a/Source/Forms/Template.pas +++ b/Source/Forms/Template.pas @@ -27,7 +27,8 @@ interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Translation, - Dialogs, StdCtrls, ComCtrls, ImgList, ControlPoint, cmap, Render, Main, Global, Adjust; + Dialogs, StdCtrls, ComCtrls, ImgList, ControlPoint, cmap, RenderingInterface, Main, + Global, Adjust; type TTemplateForm = class(TForm) @@ -60,8 +61,6 @@ TTemplateForm = class(TForm) implementation -uses ScriptForm; - {$R *.dfm} function LoadUserTemplates2(mask:string): integer; @@ -230,7 +229,7 @@ procedure ListTemplateByFileName(filename:string); p := Pos(' 0) then begin - MainForm.ListXMLScanner.LoadFromBuffer(PCHAR(FSTrings[i])); + MainForm.ListXMLScanner.LoadFromBuffer(PAnsiChar(AnsiString(FSTrings[i]))); MainForm.ListXMLScanner.Execute; if Trim(pname) = '' then @@ -316,7 +315,6 @@ procedure TTemplateForm.btnOKClick(Sender: TObject); if (TemplateList.Selected.Index = 0) then flameXML := BlankXML else flameXML := LoadXMLFlameText(fn, TemplateList.Selected.Caption); MainForm.UpdateUndo; - ScriptEditor.Stopped := True; MainForm.StopThread; MainForm.InvokeLoadXML(flameXML); Transforms := MainCp.TrianglesFromCP(MainTriangles); diff --git a/Source/Forms/Tracer.ddp b/Source/Forms/Tracer.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/Tracer.ddp and /dev/null differ diff --git a/Source/Forms/formPostProcess.ddp b/Source/Forms/formPostProcess.ddp deleted file mode 100644 index 4370276..0000000 Binary files a/Source/Forms/formPostProcess.ddp and /dev/null differ diff --git a/Source/Forms/formPostProcess.pas b/Source/Forms/formPostProcess.pas index d081aa5..f82f4f8 100644 --- a/Source/Forms/formPostProcess.pas +++ b/Source/Forms/formPostProcess.pas @@ -27,7 +27,8 @@ interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, ExtCtrls, Render, controlpoint, StdCtrls, ComCtrls, imageenio, Translation; + Dialogs, ExtCtrls, RenderingInterface, controlpoint, StdCtrls, ComCtrls, + Translation; type TfrmPostProcess = class(TForm) @@ -93,10 +94,6 @@ TfrmPostProcess = class(TForm) public cp : TControlPoint; - en : TImageEnIO; - DoStoreExif : boolean; - DoStoreExifParams : boolean; - author :string; procedure SetRenderer(Renderer: TBaseRenderer); procedure SetControlPoint(CP: TControlPoint); @@ -307,24 +304,6 @@ procedure TfrmPostProcess.btnApplyClick(Sender: TObject); procedure TfrmPostProcess.btnSaveClick(Sender: TObject); begin FRenderer.SaveImage(FImagename); - if DoStoreExif then begin - en.ParamsFromFile(FImagename); - en.Params.EXIF_HasExifData := true; - en.Params.EXIF_XPTitle := cp.name; - en.Params.EXIF_XPKeywords := 'Apophysis ' + cp.name; - en.Params.EXIF_XPAuthor := author; - en.Params.EXIF_Artist := author; - en.Params.EXIF_Software := AppVersionString; - en.Params.EXIF_DateTime := FormatDateTime('yyyy.mm.dd hh:nn:ss',Now); - en.Params.EXIF_DateTimeOriginal := en.Params.EXIF_DateTime; - en.Params.EXIF_DateTimeDigitized := en.Params.EXIF_DateTime; - en.Params.EXIF_Make := 'Apophysis'; - en.Params.EXIF_Model := AppVersionString; - if (DoStoreExifParams) then begin - en.Params.EXIF_UserComment := MainForm.RetrieveXML(cp); - end; - en.InjectJpegEXIF(FImagename); - end; end; /////////////////////////////////////////////////////////////////////////////// diff --git a/Source/IO/CommandLine.pas b/Source/IO/CommandLine.pas index 577e68d..00335c6 100644 --- a/Source/IO/CommandLine.pas +++ b/Source/IO/CommandLine.pas @@ -1,13 +1,14 @@ unit CommandLine; interface - uses Dialogs, PerlRegEx; + uses Dialogs, RegularExpressionsCore; type TCommandLine = class public CreateFromTemplate : boolean; TemplateFile : string; TemplateName : string; + Lite: boolean; procedure Load; @@ -19,19 +20,29 @@ procedure TCommandLine.Load; var Regex: TPerlRegEx; begin - Regex := TPerlRegEx.Create(nil); + Regex := TPerlRegEx.Create; Regex.RegEx := '-template\s+"(.+)"\s+"(.+)"'; Regex.Options := [preSingleLine, preCaseless]; - Regex.Subject := CmdLine; - + Regex.Subject := Utf8String(CmdLine); CreateFromTemplate := false; if Regex.Match then begin - if Regex.SubExpressionCount = 2 then begin + if Regex.GroupCount = 2 then begin CreateFromTemplate := true; - TemplateFile := Regex.SubExpressions[1]; - TemplateName := Regex.SubExpressions[2]; + TemplateFile := String(Regex.Groups[1]); + TemplateName := String(Regex.Groups[2]); end; end; + Regex.Destroy; + + Regex := TPerlRegEx.Create; + Regex.RegEx := '-lite'; + Regex.Options := [preSingleLine, preCaseless]; + Regex.Subject := Utf8String(CmdLine); + CreateFromTemplate := false; + if Regex.Match then begin + Lite := true; + end; + Regex.Destroy; end; end. diff --git a/Source/IO/Hibernation.pas b/Source/IO/Hibernation.pas index a1aadc3..75dce15 100644 --- a/Source/IO/Hibernation.pas +++ b/Source/IO/Hibernation.pas @@ -2,7 +2,7 @@ interface -uses RenderTypes, SysUtils, Windows, Forms, Classes, Binary, ControlPoint; +uses RenderingCommon, RenderingInterface, SysUtils, Windows, Forms, Classes, Binary, ControlPoint; const HIB_VERSION_MAJOR = 2; // Apophysis7X.15 diff --git a/Source/IO/MissingPlugin.pas b/Source/IO/MissingPlugin.pas index 4851c54..4dfc3cf 100644 --- a/Source/IO/MissingPlugin.pas +++ b/Source/IO/MissingPlugin.pas @@ -3,10 +3,10 @@ interface uses Windows, Global, Classes, LoadTracker, ComCtrls, SysUtils, ControlPoint, Translation; - const RegisteredAttributes : array[0..12] of string = ( + const RegisteredAttributes : array[0..13] of string = ( 'weight', 'color', 'symmetry', 'color_speed', 'coefs', 'chaos', 'plotmode', 'opacity', 'post', 'var', 'var1', 'var_color', - 'name' + 'name', 'linear3D' ); var MissingPluginList : TStringList; Parsing : boolean; @@ -71,6 +71,6 @@ implementation procedure AnnoyUser; begin if (ErrorMessageString = '') or (not WarnOnMissingPlugin) then exit; - MessageBox($00000000, PAnsiChar(ErrorMessageString), PAnsiChar('Apophysis'), MB_ICONHAND or MB_OK); + MessageBox($00000000, PChar(ErrorMessageString), PChar('Apophysis'), MB_ICONHAND or MB_OK); end; end. diff --git a/Source/IO/ParameterIO.pas b/Source/IO/ParameterIO.pas new file mode 100644 index 0000000..b5f970e --- /dev/null +++ b/Source/IO/ParameterIO.pas @@ -0,0 +1,603 @@ +unit ParameterIO; + +interface + uses Global, SysUtils, StrUtils, ControlPoint, XForm, cmap, + XFormMan, RegularExpressionsCore, RegexHelper, Classes; + +function IsRegisteredVariation(name: string): boolean; +function IsRegisteredVariable(name: string): boolean; + +procedure EnumParameters(xml: string; var list: TStringList); +function NameOf(xml: string): string; +function FindFlameInBatch(xml, name: string): string; + +procedure LoadPaletteFromXmlCompatible(xml: Utf8String; var cp: TControlPoint); +procedure LoadXFormFromXmlCompatible(xml: Utf8String; isFinalXForm: boolean; var xf: TXForm; var enabled: boolean); +function LoadCpFromXmlCompatible(xml: string; var cp: TControlPoint; var statusOutput: string): boolean; +function SaveCpToXmlCompatible(var xml: string; const cp1: TControlPoint): boolean; + +implementation + +(* *************************** Validation functions ***************************** *) +function IsRegisteredVariation(name: string): boolean; +var i, count: integer; vname: string; xf: txform; +begin +xf := txform.Create; +xf.Destroy; + count:=NrVar; + for i:=0 to count - 1 do + begin + vname := VarNames(i); + if (lowercase(vname) = lowercase(name)) then + begin + Result := true; + exit; + end; + end; + Result := false; +end; +function IsRegisteredVariable(name: string): boolean; +var i, count: integer; +begin + count:=GetNrVariableNames; + for i:=0 to count - 1 do + begin + if (LowerCase(GetVariableNameAt(i)) = LowerCase(name)) then + begin + Result := true; + exit; + end; + end; + Result := false; +end; + +(* ***************************** Loading functions ******************************* *) +function NameOf(xml: string): string; +var + Regex: TPerlRegEx; +begin + Regex := TPerlRegEx.Create; + Regex.RegEx := '.*?'; + Regex.Options := [preSingleLine, preCaseless]; + Regex.Subject := Utf8String(xml); + if Regex.Match then begin + Result := String(Regex.Groups[1]); + end else Result := ''; + Regex.Free; +end; +procedure EnumParameters(xml: string; var list: TStringList); +var + Regex: TPerlRegEx; +begin + Regex := TPerlRegEx.Create; + Regex.RegEx := '.*?'; + Regex.Options := [preSingleLine, preCaseless]; + Regex.Subject := Utf8String(xml); + if Regex.Match then begin + repeat + list.Add(String(Regex.MatchedText)); + until not Regex.MatchAgain; + end; + Regex.Free; +end; +function FindFlameInBatch(xml, name: string): string; +var + Regex: TPerlRegEx; +begin + Regex := TPerlRegEx.Create; + Regex.RegEx := '.*?'; + Regex.Options := [preSingleLine, preCaseless]; + Regex.Subject := Utf8String(xml); + if Regex.Match then begin + repeat + if (Utf8String(name) = Regex.Groups[1]) then begin + Result := String(Regex.MatchedText); + Regex.Free; + exit; + end; + until not Regex.MatchAgain; + end; + Result := ''; + Regex.Free; +end; + +function LoadCpFromXmlCompatible(xml: string; var cp: TControlPoint; var statusOutput: string): boolean; +const + re_flame : string = '(.*?)'; + re_xform : string = '<((?:final)?xform)(.*?)/>'; + re_palette : string = '([a-f0-9\s]+)'; + re_attrib : string = '([0-9a-z_]+)="(.*?)"'; + re_strtoken : string = '([a-z0-9_]+)'; +var + flame_attribs : Utf8String; + flame_content : Utf8String; + xform_type : Utf8String; + xform_attribs : Utf8String; + palette_attribs : Utf8String; + palette_content : Utf8String; + + find_attribs : TPerlRegEx; + found_attrib : boolean; + attrib_name : Utf8String; + attrib_match : Utf8String; + + find_xforms : TPerlRegEx; + found_xform : boolean; + xform_index : integer; + + find_strtokens : TPerlRegEx; + found_strtoken : boolean; + strtoken_index : integer; + strtoken_value : Utf8String; + + find_palette : TPerlRegEx; + + temp2i : T2Int; + temp2f : T2Float; + temprgb : TRGB; + + dummy: boolean; + attrib_success: boolean; + i: integer; +begin + find_strtokens := TPerlRegEx.Create; + find_attribs := TPerlRegEx.Create; + find_xforms := TPerlRegEx.Create; + find_palette := TPerlRegEx.Create; + + find_attribs.RegEx := Utf8String(re_attrib); + find_strtokens.RegEx := Utf8String(re_strtoken); + find_xforms.RegEx := Utf8String(re_xform); + find_palette.RegEx := Utf8String(re_palette); + + find_attribs.Options := [preSingleLine, preCaseless]; + find_strtokens.Options := [preSingleLine, preCaseless]; + find_xforms.Options := [preSingleLine, preCaseless]; + find_palette.Options := [preSingleLine, preCaseless]; + + flame_attribs := Utf8String(GetStringPart(xml, re_flame, 1, '')); + flame_content := Utf8String(GetStringPart(xml, re_flame, 2, '')); + + find_attribs.Subject := Utf8String(flame_attribs); + found_attrib := find_attribs.Match; + + Result := true; + + while found_attrib do begin + attrib_match := find_attribs.MatchedText; + attrib_name := Utf8String(Lowercase(String(find_attribs.Groups[1]))); + attrib_success := true; + + if attrib_name = 'name' then + cp.name := GetStringPart(String(attrib_match), re_attrib, 2, '') + else if attrib_name = 'vibrancy' then + cp.vibrancy := GetFloatPart(String(attrib_match), re_attrib, 2, defVibrancy) + else if attrib_name = 'brightness' then + cp.brightness := GetFloatPart(String(attrib_match), re_attrib, 2, defBrightness) + else if attrib_name = 'gamma' then + cp.gamma := GetFloatPart(String(attrib_match), re_attrib, 2, defGamma) + else if attrib_name = 'gamma_threshold' then + cp.gamma_threshold := GetFloatPart(String(attrib_match), re_attrib, 2, defGammaThreshold) + else if attrib_name = 'oversample' then + cp.spatial_oversample := GetIntPart(String(attrib_match), re_attrib, 2, defOversample) + else if attrib_name = 'filter' then + cp.spatial_filter_radius := GetFloatPart(String(attrib_match), re_attrib, 2, defFilterRadius) + else if attrib_name = 'zoom' then + cp.zoom := GetFloatPart(String(attrib_match), re_attrib, 2, 0) + else if attrib_name = 'scale' then + cp.pixels_per_unit := GetFloatPart(String(attrib_match), re_attrib, 2, 25) + else if attrib_name = 'quality' then + cp.sample_density := GetFloatPart(String(attrib_match), re_attrib, 2, 5) + else if attrib_name = 'angle' then + cp.fangle := GetFloatPart(String(attrib_match), re_attrib, 2, 0) + else if attrib_name = 'rotate' then // angle = -pi*x/180 + cp.vibrancy := -PI * GetFloatPart(String(attrib_match), re_attrib, 2, 0) / 180 + else if attrib_name = 'cam_pitch' then + cp.cameraPitch := GetFloatPart(String(attrib_match), re_attrib, 2, 0) + else if attrib_name = 'cam_yaw' then + cp.cameraYaw := GetFloatPart(String(attrib_match), re_attrib, 2, 0) + else if attrib_name = 'cam_perspective' then + cp.cameraPersp := GetFloatPart(String(attrib_match), re_attrib, 2, 1) + else if attrib_name = 'cam_dist' then // perspective = 1/x + begin + cp.cameraPersp := GetFloatPart(String(attrib_match), re_attrib, 2, 1); + if cp.cameraPersp = 0 then + cp.cameraPersp := EPS; + cp.cameraPersp := 1 / cp.cameraPersp; + end + else if attrib_name = 'cam_zpos' then + cp.cameraZpos := GetFloatPart(String(attrib_match), re_attrib, 2, 0) + else if attrib_name = 'cam_dof' then + cp.cameraDOF := GetFloatPart(String(attrib_match), re_attrib, 2, 0) + + else if attrib_name = 'estimator_radius' then + cp.estimator := GetFloatPart(String(attrib_match), re_attrib, 2, 0) + else if attrib_name = 'estimator_minimum' then + cp.estimator_min := GetFloatPart(String(attrib_match), re_attrib, 2, 0) + else if attrib_name = 'estimator_curve' then + cp.estimator_curve := GetFloatPart(String(attrib_match), re_attrib, 2, 0) + else if attrib_name = 'enable_de' then + cp.enable_de := GetBoolPart(String(attrib_match), re_attrib, 2, false) + + else if attrib_name = 'center' then + begin + temp2f := Get2FloatPart(String(attrib_match), re_attrib, 2, 0); + cp.center[0] := temp2f.f1; cp.center[1] := temp2f.f2; + end + else if attrib_name = 'size' then + begin + temp2i := Get2IntPart(String(attrib_match), re_attrib, 2, 0); + cp.Width := temp2i.i1; cp.Height := temp2i.i2; + end + else if attrib_name = 'background' then + begin + temprgb := GetRGBPart(String(attrib_match), re_attrib, 2, 0); + cp.background[0] := temprgb.r; + cp.background[1] := temprgb.g; + cp.background[2] := temprgb.b; + end + + else if attrib_name = 'soloxform' then + cp.soloXform := GetIntPart(String(attrib_match), re_attrib, 2, 0); + + found_attrib := find_attribs.MatchAgain; + end; + + if LimitVibrancy and (cp.vibrancy > 1) then + cp.vibrancy := 1; + cp.cmapindex := -1; + + find_xforms.Subject := flame_content; + found_xform := find_xforms.Match; + xform_index := 0; + cp.finalXformEnabled := false; + + for i := 0 TO NXFORMS - 1 do + cp.xform[i].density := 0; + + while found_xform do begin + xform_type := find_xforms.Groups[1]; + xform_attribs := find_xforms.Groups[2]; + if (LowerCase(String(xform_type)) = 'xform') then begin + LoadXFormFromXmlCompatible(find_xforms.MatchedText, + false, cp.xform[xform_index], cp.finalXformEnabled); + xform_index := xform_index + 1; + end else begin + cp.finalXform := Txform.Create; + LoadXFormFromXmlCompatible(find_xforms.MatchedText, + true, cp.finalXform, dummy); + cp.finalXformEnabled := true; + cp.useFinalXform := true; + xform_index := xform_index + 1; + cp.xform[cp.NumXForms] := cp.finalXform; + end; + found_xform := find_xforms.MatchAgain; + end; + + find_palette.Subject := Utf8String(xml); + if (find_palette.Match) then + LoadPaletteFromXmlCompatible(find_palette.MatchedText, cp); + + find_strtokens.Free; + find_attribs.Free; + find_xforms.Free; + find_palette.Free; +end; +procedure LoadPaletteFromXmlCompatible(xml: Utf8String; var cp: TControlPoint); +const + re_palette: string = '([a-f0-9\s]+)'; + re_attrib : string = '([0-9a-z_]+)="(.*?)"'; +var + i, pos, len, count: integer; c: char; + data, attr, hexdata, format: string; + alpha: boolean; + + find_attribs : TPerlRegEx; + found_attrib : boolean; + attrib_name : Utf8String; + attrib_match : Utf8String; + attrib_success : Boolean; +function HexChar(c: Char): Byte; + begin + case c of + '0'..'9': Result := (Byte(c) - Byte('0')); + 'a'..'f': Result := (Byte(c) - Byte('a')) + 10; + 'A'..'F': Result := (Byte(c) - Byte('A')) + 10; + else + Result := 0; + end; + end; +begin + hexdata := GetStringPart(String(xml), re_palette, 2, ''); + attr := GetStringPart(String(xml), re_palette, 1, ''); + + find_attribs := TPerlRegEx.Create; + find_attribs.RegEx := Utf8String(re_attrib); + find_attribs.Options := [preSingleLine, preCaseless]; + find_attribs.Subject := Utf8String(attr); + found_attrib := find_attribs.Match; + + count := 0; + + while found_attrib do begin + attrib_match := find_attribs.MatchedText; + attrib_name := Utf8String(Lowercase(String(find_attribs.Groups[1]))); + attrib_success := true; + + if (attrib_name = 'count') then + count := GetIntPart(String(attrib_match), re_attrib, 2, 256) + else if (attrib_name = 'format') then + format := GetStringPart(String(attrib_match), re_attrib, 2, 'RGB'); + + found_attrib := find_attribs.MatchAgain; + end; + + find_attribs.Free; + + alpha := (lowercase(format) = 'rgba'); + data := ''; + + for i := 1 to Length(hexdata) do + begin + c := hexdata[i]; + if CharInSet(c, ['0'..'9']+['A'..'F']+['a'..'f']) then data := data + c; + end; + + if alpha then len := count * 8 + else len := count * 6; + + for i := 0 to Count-1 do begin + if alpha then pos := i * 8 + 2 + else pos := i * 6; + cp.cmap[i][0] := 16 * HexChar(Data[pos + 1]) + HexChar(Data[pos + 2]); + cp.cmap[i][1] := 16 * HexChar(Data[pos + 3]) + HexChar(Data[pos + 4]); + cp.cmap[i][2] := 16 * HexChar(Data[pos + 5]) + HexChar(Data[pos + 6]); + end; +end; +procedure LoadXFormFromXmlCompatible(xml: Utf8String; isFinalXForm: boolean; var xf: TXForm; var enabled: boolean); +const + re_attrib : string = '([0-9a-z_]+)="(.*?)"'; + re_xform : string = '<((?:final)?xform)(.*?)/>'; + re_coefs : string = '([\d.eE+-]+)\s+([\d.eE+-]+)\s+([\d.eE+-]+)\s+([\d.eE+-]+)\s+([\d.eE+-]+)\s+([\d.eE+-]+)'; +var + xform_attribs: string; + find_attribs : TPerlRegEx; + found_attrib : boolean; + attrib_name : Utf8String; + attrib_match : Utf8String; + token_part : string; + i, j : integer; + d : double; + t : TStringList; + v_set : Boolean; + attrib_success: Boolean; +begin + enabled := true; + xform_attribs := GetStringPart(String(xml), re_xform, 2, ''); + + find_attribs := TPerlRegEx.Create; + find_attribs.RegEx := Utf8String(re_attrib); + find_attribs.Options := [preSingleLine, preCaseless]; + find_attribs.Subject := Utf8String(xform_attribs); + found_attrib := find_attribs.Match; + + for i := 0 to NRVAR-1 do + xf.SetVariation(i, 0); + + while found_attrib do begin + attrib_match := find_attribs.MatchedText; + attrib_name := (find_attribs.Groups[1]); + attrib_success := true; + + if (attrib_name = 'enabled') and isFinalXform then + enabled := GetBoolPart(String(attrib_match), re_attrib, 2, true) + else if (attrib_name = 'weight') and (not isFinalXform) then + xf.density := GetFloatPart(String(attrib_match), re_attrib, 2, 0.5) + else if (attrib_name = 'symmetry') and (not isFinalXform) then + xf.symmetry := GetFloatPart(String(attrib_match), re_attrib, 2, 0) + else if (attrib_name = 'color_speed') and (not isFinalXform) then + xf.symmetry := GetFloatPart(String(attrib_match), re_attrib, 2, 0) + else if (attrib_name = 'chaos') and (not isFinalXform) then + begin + token_part := GetStringPart(String(attrib_match), re_attrib, 2, ''); + if token_part <> '' then + begin + t := TStringList.Create; + GetTokens(token_part, t); + for i := 0 to t.Count-1 do + xf.modWeights[i] := Abs(StrToFloat(t[i])); + t.Destroy; + end; + end + else if (attrib_name = 'opacity') and (not isFinalXform) then + xf.transOpacity := GetFloatPart(String(attrib_match), re_attrib, 2, 1) + else if (attrib_name = 'name') and (not isFinalXform) then + xf.TransformName := GetStringPart(String(attrib_match), re_attrib, 2, '') + else if (attrib_name = 'plotmode') and (not isFinalXform) then + xf.transOpacity := StrToFloat(IfThen(LowerCase(GetStringPart(String(attrib_match), re_attrib, 2, '')) = 'off', '0', '1')) + else if (attrib_name = 'coefs') then + begin + token_part := GetStringPart(String(attrib_match), re_attrib, 2, '1 0 0 1 0 0'); + xf.c[0][0] := GetFloatPart(token_part, re_coefs, 1, 1); + xf.c[0][1] := GetFloatPart(token_part, re_coefs, 2, 0); + xf.c[1][0] := GetFloatPart(token_part, re_coefs, 3, 0); + xf.c[1][1] := GetFloatPart(token_part, re_coefs, 4, 1); + xf.c[2][0] := GetFloatPart(token_part, re_coefs, 5, 0); + xf.c[2][1] := GetFloatPart(token_part, re_coefs, 6, 0); + end + else if (attrib_name = 'post') then + begin + token_part := GetStringPart(String(attrib_match), re_attrib, 2, '1 0 0 1 0 0'); + xf.p[0][0] := GetFloatPart(token_part, re_coefs, 1, 1); + xf.p[0][1] := GetFloatPart(token_part, re_coefs, 2, 0); + xf.p[1][0] := GetFloatPart(token_part, re_coefs, 3, 0); + xf.p[1][1] := GetFloatPart(token_part, re_coefs, 4, 1); + xf.p[2][0] := GetFloatPart(token_part, re_coefs, 5, 0); + xf.p[2][1] := GetFloatPart(token_part, re_coefs, 6, 0); + end + else if (attrib_name = 'color') then + xf.color := GetFloatPart(String(attrib_match), re_attrib, 2, 0) + else if (attrib_name = 'var_color') then + xf.vc := GetFloatPart(String(attrib_match), re_attrib, 2, 1) + else if ((String(attrib_name) = 'symmetry') or (String(attrib_name) = 'weight') or + (String(attrib_name) = 'color_speed') or (String(attrib_name) = 'chaos') or + (String(attrib_name) = 'opacity') or (String(attrib_name) = 'name') or + (String(attrib_name) = 'plotmode')) and (isFinalXForm) then + begin + //EmitWarning('Malformed attribute "xform.' + attrib_name + '" - ignoring'); + //LogWrite('WARNING|' +'Malformed attribute "xform.' + attrib_name + '" - ignoring', 'parser.log'); + attrib_success := false; + end + else begin + if (String(attrib_name) = 'linear3D') then begin + xf.SetVariation(0, GetFloatPart(String(attrib_match), re_attrib, 2, 0)); + end else if (IsRegisteredVariation(String(attrib_name))) then begin + for i := 0 to NRVAR - 1 do begin + if lowercase(varnames(i)) = lowercase(String(attrib_name)) then begin + xf.SetVariation(i, GetFloatPart(String(attrib_match), re_attrib, 2, 0)); + v_set := true; + break; + end; + end; + if (IsRegisteredVariable(String(attrib_name))) then begin + d := GetFloatPart(String(attrib_match), re_attrib, 2, 0); + xf.SetVariable(String(attrib_name), d); + end; + end else if (IsRegisteredVariable(String(attrib_name))) then begin + d := GetFloatPart(String(attrib_match), re_attrib, 2, 0); + xf.SetVariable(String(attrib_name), d); + end; + attrib_success := false; + end; + + found_attrib := find_attribs.MatchAgain; + end; + + if (isFinalXform) then begin + xf.symmetry := 1; + xf.color := 0; + end; + + find_attribs.Free; +end; + +// Replace... +function SaveCpToXmlCompatible(var xml: string; const cp1: TControlPoint): boolean; +function ColorToXmlCompact(cp1: TControlPoint): string; +var + i: integer; +begin + Result := ' '; + for i := 0 to 255 do begin + if ((i and 7) = 0) then Result := Result + #13#10 + ' '; + Result := Result + IntToHex(cp1.cmap[i, 0],2) + + IntToHex(cp1.cmap[i, 1],2) + + IntToHex(cp1.cmap[i, 2],2); + end; + Result := Result + #13#10 + ' '; +end; +var + t, i{, j}: integer; + FileList: TStringList; + x, y: double; + parameters: string; + str: string; +begin + FileList := TStringList.create; + x := cp1.center[0]; + y := cp1.center[1]; + +// if cp1.cmapindex >= 0 then pal := pal + 'gradient="' + IntToStr(cp1.cmapindex) + '" '; + + try + parameters := 'version="Apophysis 7X" '; + if cp1.time <> 0 then + parameters := parameters + format('time="%g" ', [cp1.time]); + + parameters := parameters + + 'size="' + IntToStr(cp1.width) + ' ' + IntToStr(cp1.height) + + format('" center="%g %g" ', [x, y]) + + format('scale="%g" ', [cp1.pixels_per_unit]); + + if cp1.FAngle <> 0 then + parameters := parameters + format('angle="%g" ', [cp1.FAngle]) + + format('rotate="%g" ', [-180 * cp1.FAngle/Pi]); + if cp1.zoom <> 0 then + parameters := parameters + format('zoom="%g" ', [cp1.zoom]); + +// 3d + if cp1.cameraPitch <> 0 then + parameters := parameters + format('cam_pitch="%g" ', [cp1.cameraPitch]); + if cp1.cameraYaw <> 0 then + parameters := parameters + format('cam_yaw="%g" ', [cp1.cameraYaw]); + if cp1.cameraPersp <> 0 then + parameters := parameters + format('cam_perspective="%g" ', [cp1.cameraPersp]); + if cp1.cameraZpos <> 0 then + parameters := parameters + format('cam_zpos="%g" ', [cp1.cameraZpos]); + if cp1.cameraDOF <> 0 then + parameters := parameters + format('cam_dof="%g" ', [cp1.cameraDOF]); +// + parameters := parameters + format( + 'oversample="%d" filter="%g" quality="%g" ', + [cp1.spatial_oversample, + cp1.spatial_filter_radius, + cp1.sample_density] + ); + if cp1.nbatches <> 1 then parameters := parameters + 'batches="' + IntToStr(cp1.nbatches) + '" '; + + parameters := parameters + + format('background="%g %g %g" ', [cp1.background[0] / 255, cp1.background[1] / 255, cp1.background[2] / 255]) + + format('brightness="%g" ', [cp1.brightness]) + + format('gamma="%g" ', [cp1.gamma]); + + if cp1.vibrancy <> 1 then + parameters := parameters + format('vibrancy="%g" ', [cp1.vibrancy]); + + if cp1.gamma_threshold <> 0 then + parameters := parameters + format('gamma_threshold="%g" ', [cp1.gamma_threshold]); + + if cp1.soloXform >= 0 then + parameters := parameters + format('soloxform="%d" ', [cp1.soloXform]); + + parameters := parameters + + format('estimator_radius="%g" ', [cp1.estimator]) + + format('estimator_minimum="%g" ', [cp1.estimator_min]) + + format('estimator_curve="%g" ', [cp1.estimator_curve]); + if (cp1.enable_de) then + parameters := parameters + ('enable_de="1" ') + else parameters := parameters + ('enable_de="0" '); + + str := ''; + for i := 0 to cp1.used_plugins.Count-1 do begin + str := str + cp1.used_plugins[i]; + if (i = cp1.used_plugins.Count-1) then break; + str := str + ' '; + end; + parameters := parameters + format('plugins="%s" ', [str]); + + FileList.Add(''); + { Write transform parameters } + t := cp1.NumXForms; + for i := 0 to t - 1 do + FileList.Add(cp1.xform[i].ToXMLString); + if cp1.HasFinalXForm then + begin + // 'enabled' flag disabled in this release + FileList.Add(cp1.xform[t].FinalToXMLString(cp1.finalXformEnabled)); + end; + + { Write palette data } + //if exporting or OldPaletteFormat then + // FileList.Add(ColorToXml(cp1)) + //else + FileList.Add(ColorToXmlCompact(cp1)); + + FileList.Add(''); + xml := FileList.text; + result := true; + finally + FileList.free + end; +end; + +end. diff --git a/Source/IO/Regstry.pas b/Source/IO/Regstry.pas index 21ccecb..e6ae0a4 100644 --- a/Source/IO/Regstry.pas +++ b/Source/IO/Regstry.pas @@ -51,8 +51,7 @@ procedure ReadSettings; i, maxVars: integer; VariationOptions: int64; begin - DefaultPath := ExtractFilePath(Application.Exename); -// ShowMessage(DefaultPath); + DefaultPath := GetEnvVarValue('USERPROFILE');///ExtractFilePath(Application.Exename); Registry := TRegistry.Create; try Registry.RootKey := HKEY_CURRENT_USER; @@ -96,7 +95,7 @@ procedure ReadSettings; if Registry.ValueExists('SavePath') then SavePath := Registry.ReadString('SavePath') else - SavePath := DefaultPath + 'Parameters\My 3D Flames.flame'; + SavePath := DefaultPath + '\Flames.flame'; end; if Registry.ValueExists('EmbedThumbnails') then @@ -122,7 +121,7 @@ procedure ReadSettings; end else begin - defSmoothPaletteFile := DefaultPath + 'smooth.ugr'; + defSmoothPaletteFile := DefaultPath + '\SmoothPalette.ugr'; end; if Registry.ValueExists('PlaySoundOnRenderComplete') then @@ -239,7 +238,7 @@ procedure ReadSettings; end else begin - ParamFolder := DefaultPath + 'Parameters\'; + ParamFolder := DefaultPath + '\'; end; if Registry.ValueExists('UPRPath') then @@ -248,7 +247,7 @@ procedure ReadSettings; end else begin - UPRPath := DefaultPath; + UPRPath := DefaultPath + '\'; end; if Registry.ValueExists('ImageFolder') then @@ -257,7 +256,7 @@ procedure ReadSettings; end else begin - ImageFolder := DefaultPath; + ImageFolder := DefaultPath + '\'; end; if Registry.ValueExists('UPRWidth') then @@ -283,7 +282,7 @@ procedure ReadSettings; end else begin - BrowserPath := DefaultPath; + BrowserPath := DefaultPath + '\'; end; if Registry.ValueExists('EditPreviewQaulity') then begin @@ -475,7 +474,7 @@ procedure ReadSettings; end else begin - ScriptPath := DefaultPath + 'Scripts\'; + ScriptPath := DefaultPath + '\Scripts\'; end; if Registry.ValueExists('FunctionLibrary') then begin @@ -483,7 +482,7 @@ procedure ReadSettings; end else begin - defLibrary := DefaultPath + 'Scripts\Functions.asc'; + defLibrary := ExtractFilePath(Application.ExeName) + 'Functions.asc'; end; if Registry.ValueExists('ExportFileFormat') then begin @@ -577,7 +576,7 @@ procedure ReadSettings; end else begin - flam3Path := DefaultPath + 'flam3.exe'; + flam3Path := ExtractFilePath(Application.ExeName) + 'flam3.exe'; end; if Registry.ValueExists('Server') then begin @@ -756,7 +755,7 @@ procedure ReadSettings; if Registry.ValueExists('HelpPath') then begin HelpPath := Registry.ReadString('HelpPath'); end else begin - HelpPath := DefaultPath + 'Apophysis 2.0.chm'; + HelpPath := ExtractFilePath(Application.ExeName) + 'Apophysis 7X.chm'; end; if Registry.ValueExists('ChaoticaPath') then begin @@ -774,10 +773,24 @@ procedure ReadSettings; end else begin UseX64IfPossible := false; end; + + if Registry.ValueExists('PluginPath') then begin + PluginPath := Registry.ReadString('PluginPath'); + end else begin + PluginPath := ExtractFilePath(Application.ExeName) + 'Plugins\'; + end; + + {if Registry.ValueExists('SingleBuffer') then begin + SingleBuffer := Registry.ReadBool('SingleBuffer'); + end else begin + SingleBuffer := false; + end;} end else begin // ReferenceMode := 0; + //SingleBuffer := false; + PluginPath := ExtractFilePath(Application.ExeName) + 'Plugins\'; StartupCheckForUpdates := true; AlwaysCreateBlankFlame := false; MainForm_RotationMode := 0; @@ -786,12 +799,12 @@ procedure ReadSettings; AdjustPrevQual := 1; GradientFile := ''; defFlameFile := ''; - SavePath := DefaultPath + 'Parameters\My 3D Flames.flame'; + SavePath := DefaultPath + '\Flames.flame'; EmbedThumbnails := false; WarnOnMissingPlugin := true; LanguageFile := ''; - HelpPath := DefaultPath + 'Apophysis 2.0.chm'; - defSmoothPaletteFile := DefaultPath + 'smooth.ugr'; + HelpPath := ExtractFilePath(Application.ExeName) + 'Apophysis 7X.chm'; + defSmoothPaletteFile := DefaultPath + '\SmoothPalette.ugr'; ConfirmDelete := True; ConfirmExit := True; OldPaletteFormat := false; @@ -804,12 +817,12 @@ procedure ReadSettings; randGradient := 0; PreserveQuality := false; KeepBackground := False; - UPRPath := DefaultPath; - ImageFolder := DefaultPath; - ParamFolder := DefaultPath + 'Parameters\'; + UPRPath := DefaultPath + '\'; + ImageFolder := DefaultPath + '\'; + ParamFolder := DefaultPath + '\'; UPRWidth := 640; UPRHeight := 480; - RandomPrefix := 'Apo3D-'; + RandomPrefix := 'Apo7X-'; RandomIndex := 0; RandomDate := ''; SymmetryType := 0; @@ -827,8 +840,8 @@ procedure ReadSettings; MaxLum := 100; randGradientFile := ''; BatchSize := 100; - ScriptPath := DefaultPath + 'Scripts\'; - defLibrary := DefaultPath + 'Scripts\Functions.asc'; + ScriptPath := DefaultPath + '\'; + defLibrary := ExtractFilePath(Application.ExeName) + 'Functions.asc'; ExportFileFormat := 1; ExportWidth := 640; ExportHeight := 480; @@ -839,7 +852,7 @@ procedure ReadSettings; SheepNick := ''; SheepURL := ''; SheepPW := ''; - flam3Path := DefaultPath + 'flam3.exe'; + flam3Path := ExtractFilePath(Application.ExeName) + 'flam3.exe'; SheepServer := 'http://v2d5.sheepserver.net/'; ShowProgress := true; SaveIncompleteRenders := false; @@ -909,7 +922,7 @@ procedure ReadSettings; if Registry.ValueExists('EnableEditorPreview') then EnableEditorPreview := Registry.ReadBool('EnableEditorPreview') else - EnableEditorPreview := true; + EnableEditorPreview := false; if Registry.ValueExists('EditorPreviewTransparency') then EditorPreviewTransparency := Registry.ReadInteger('EditorPreviewTransparency') else @@ -949,7 +962,7 @@ procedure ReadSettings; UseTransformColors := false; HelpersEnabled := true; ShowAllXforms := true; - EnableEditorPreview := true; + EnableEditorPreview := false; EditorPreviewTransparency := 192; EditorBkgColor := $000000; GridColor1 := $444444; @@ -971,7 +984,7 @@ procedure ReadSettings; end else begin - RenderPath := DefaultPath; + RenderPath := DefaultPath + '\'; end; if Registry.ValueExists('SampleDensity') then begin @@ -1059,7 +1072,7 @@ procedure ReadSettings; begin renderFileFormat := 2; JPEGQuality := 100; - renderPath := DefaultPath; + renderPath := DefaultPath + '\'; renderDensity := 200; renderOversample := 2; renderFilterRadius := 0.4; @@ -1284,12 +1297,12 @@ procedure ReadSettings; end else begin - AutoSavePath := 'autosave.flame'; + AutoSavePath := GetEnvVarValue('USERPROFILE') + '\autosave.flame'; end; end else begin AutoSaveEnabled := false; AutoSaveFreq := 2; - AutoSavePath := 'autosave.flame'; + AutoSavePath := GetEnvVarValue('USERPROFILE') + '\autosave.flame'; end; Registry.CloseKey; finally @@ -1336,6 +1349,8 @@ procedure SaveSettings; Registry.WriteString('ChaoticaPath', ChaoticaPath); Registry.WriteString('ChaoticaPath64', ChaoticaPath64); Registry.WriteBool('UseX64IfPossible', UseX64IfPossible); + Registry.WriteString('PluginPath', PluginPath); + //Registry.WriteBool('SingleBuffer', SingleBuffer); Registry.WriteBool('ConfirmDelete', ConfirmDelete); Registry.WriteBool('OldPaletteFormat', OldPaletteFormat); diff --git a/Source/Plugin/apoplugin.h b/Source/Plugin/apoplugin.h new file mode 100644 index 0000000..d1ba5ca --- /dev/null +++ b/Source/Plugin/apoplugin.h @@ -0,0 +1,427 @@ +/* + Apophysis Plugin + (C) 2007 Joel Faber + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +#ifndef _APOPLUGIN_H_ +#define _APOPLUGIN_H_ + +#include +#include +#include +#include +#include +#include + +#ifndef TRUE +#define TRUE (1) +#define FALSE (0) +#endif + +/* The following ahve been defined in math.h: + M_E 2.7182818284590452354 + M_LOG2E 1.4426950408889634074 + M_LOG10E 0.43429448190325182765 + M_LN2 0.69314718055994530942 + M_LN10 2.30258509299404568402 + M_PI 3.14159265358979323846 + M_PI_2 1.57079632679489661923 + M_PI_4 0.78539816339744830962 + M_1_PI 0.31830988618379067154 + M_2_PI 0.63661977236758134308 + M_2_SQRTPI 1.12837916709551257390 + M_SQRT2 1.41421356237309504880 + M_SQRT1_2 0.70710678118654752440 +*/ + +// Define a few more that might be commonly used: +#define M_2PI 6.283185307179586476925286766559 +#define M_3PI_4 2.3561944901923449288469825374596 +#define M_SQRT3 1.7320508075688772935274463415059 +#define M_SQRT3_2 0.86602540378443864676372317075249 +#define M_SQRT5 2.2360679774997896964091736687313 +#define M_PHI 1.61803398874989484820458683436563 // Goldon ratio +#define M_1_2PI 0.15915494309189533576888376337251 + +#define EPS 1.0e-20 + +#define MAX(a, b) ((a) > (b) ? (a) : (b)) + +# define DLLIMPORT __declspec (dllexport) + +typedef enum +{ + REAL, + REAL_CYCLIC, + INTEGER, + INTEGER_NONZERO +} VarType; + +typedef union +{ + int i; + double d; +} IntOrDouble; + +typedef struct +{ + const char* name; + const VarType type; + int offset; + IntOrDouble min; + IntOrDouble max; + IntOrDouble def; +} VariableInfo; + +VariableInfo VarInfo[]; +const char* VariationName; +const int NumVariables; + +double dummyFTz, dummyFPz, dummyColor; + +/*************** Variation variable code ***************/ + +typedef struct +{ + double vvar; + double* pFTx; + double* pFTy; + double* pFTz; + double* pFPx; + double* pFPy; + double* pFPz; + double* pColor; + double a, b, c, d, e, f; + Variables var; +} Variation; + +#define OFFSET(name) ((int) &(((Variables*) 0)->name)) + +#define INT_LVALUE(varptr, info) ( *((int*) (((int) &((varptr)->var)) + (info).offset))) +#define DOUBLE_LVALUE(varptr, info) ( *((double*) (((int) &((varptr)->var)) + (info).offset))) +#define VALUE(varptr, info) ( (info).type >= INTEGER ? INT_LVALUE(varptr, info) : DOUBLE_LVALUE(varptr, info) ) + + +#define APO_VARIABLES(...) VariableInfo VarInfo[] = {__VA_ARGS__}; \ + const int NumVariables = sizeof(VarInfo) / sizeof(VariableInfo) + +#define VAR_REAL(nm, def) { #nm, REAL, OFFSET(nm), (IntOrDouble) -DBL_MAX, (IntOrDouble) DBL_MAX, (IntOrDouble) (def) } +#define VAR_INTEGER(nm, def) { #nm, INTEGER, OFFSET(nm), (IntOrDouble) INT_MIN, (IntOrDouble) INT_MAX, (IntOrDouble) (def) } +#define VAR_REAL_RANGE(nm, min, max, def) {#nm, REAL, OFFSET(nm), (IntOrDouble) (min), (IntOrDouble) (max), (IntOrDouble) (def) } +#define VAR_INTEGER_RANGE(nm, min, max, def) {#nm, INTEGER, OFFSET(nm), (IntOrDouble) (min), (IntOrDouble) (max), (IntOrDouble) (def) } +#define VAR_INTEGER_NONZERO(nm, def) {#nm, INTEGER_NONZERO, OFFSET(nm), (IntOrDouble) INT_MIN, (IntOrDouble) INT_MAX, (IntOrDouble) (def) } +#define VAR_REAL_CYCLE(nm, min, max, def) {#nm, REAL_CYCLIC, OFFSET(nm), (IntOrDouble) (min), (IntOrDouble) (max), (IntOrDouble) (def) } + +#define INTDOUBLE(intordouble, type) ((type) >= INTEGER ? (intordouble).i : (intordouble).d) + +// Convert the variable to a double +#define DBL_VALUE(intordouble, type) ( (type) >= INTEGER ? ((double) (intordouble).i) : (intordouble).d ) + +/*************** Declarations for .C file ***************/ +/* These functions must be defined in the variation .c file. */ +DLLIMPORT int PluginVarPrepare(Variation* vp); +DLLIMPORT int PluginVarCalc(Variation* vp); + +// Useful defines for the Prepare and Calc functions. Makes the code easier +// on the coder, but requires him/her to call the variation pointer "vp". +#define FTx (*(vp->pFTx)) +#define FTy (*(vp->pFTy)) +#define FTz (*(vp->pFTz)) +#define FPx (*(vp->pFPx)) +#define FPy (*(vp->pFPy)) +#define FPz (*(vp->pFPz)) +#define VAR(name) (vp->var.name) +#define VVAR (vp->vvar) + +// Defines for DirectColor (TC = Transform color, TM = TransformMatrix - name is a-f) +#define TC (*(vp->pColor)) +#define TM(name) (vp->name) + +/*************** Additional Function Prototypes ***************/ +DLLIMPORT int PluginVarResetVariable(void* VariationPtr, const char* name); + +/*************** Variation information code ***************/ +#define APO_PLUGIN(x) const char* VariationName = x + +DLLIMPORT const char* PluginVarGetName(void) +{ + return VariationName; +} + +DLLIMPORT int PluginVarGetNrVariables(void) +{ + return NumVariables; +} + +/*************** Plugin Creation, Destruction & Initialization ***************/ +DLLIMPORT void* PluginVarCreate(void) +{ + int i; + Variation* vp = (Variation*) calloc(1, sizeof(Variation)); + + // reset every variable to the default value. + for (i = 0 ; i < NumVariables; i++) + { + PluginVarResetVariable(vp, VarInfo[i].name); + } + + return vp; +} + +DLLIMPORT int PluginVarDestroy(void** vpp) +{ + if (vpp && *vpp) + { + free(*vpp); + *vpp = NULL; + return TRUE; + } + + return FALSE; +} + +DLLIMPORT int PluginVarInit(void* varptr, void* pFPx, void* pFPy, void* pFTx, void* pFTy, double vvar) +{ + Variation* vp = (Variation*) varptr; + + if (vp == NULL) + return FALSE; + vp->pFPx = (double*) pFPx; + vp->pFPy = (double*) pFPy; + vp->pFTx = (double*) pFTx; + vp->pFTy = (double*) pFTy; + + // Dummy values... must call PluginVarInit3D to set the + // pointers to addresses that Apophysis knows about. + vp->pFTz = &dummyFTz; + vp->pFPz = &dummyFPz; + vp->pColor = &dummyColor; + dummyFTz = 0; + dummyFPz = 0; + + // dummies for DC + dummyColor = 0; + vp->a = vp->d = 1; + vp->b = vp->c = vp->e = vp->f = 0; + + vp->vvar = vvar; + + return TRUE; +} + +DLLIMPORT int PluginVarInit3D(void* varptr, void* pFPx, void* pFPy, void* pFPz, void* pFTx, void* pFTy, void* pFTz, double vvar) +{ + Variation* vp = (Variation*) varptr; + + if (vp == NULL) + return FALSE; + vp->pFPx = (double*) pFPx; + vp->pFPy = (double*) pFPy; + vp->pFPz = (double*) pFPz; + vp->pFTx = (double*) pFTx; + vp->pFTy = (double*) pFTy; + vp->pFTz = (double*) pFTz; + vp->pColor = &dummyColor; + vp->vvar = vvar; + + // dummies for DC + dummyColor = 0; + vp->a = vp->d = 1; + vp->b = vp->c = vp->e = vp->f = 0; + + return TRUE; +} + +// DirectColor support for Apo7X +DLLIMPORT int PluginVarInitDC(void* varptr, void* pFPx, void* pFPy, void* pFPz, void* pFTx, void* pFTy, void* pFTz, void* pColor, double vvar, double a, double b, double c, double d, double e, double f) +{ + Variation* vp = (Variation*) varptr; + + if (vp == NULL) + return FALSE; + vp->pFPx = (double*) pFPx; + vp->pFPy = (double*) pFPy; + vp->pFPz = (double*) pFPz; + vp->pFTx = (double*) pFTx; + vp->pFTy = (double*) pFTy; + vp->pFTz = (double*) pFTz; + vp->vvar = vvar; + + vp->pColor = (double*) pColor; + vp->a = a; vp->b = b; vp->c = c; + vp->d = d; vp->e = e; vp->f = f; + + return TRUE; +} + +DLLIMPORT int PluginVarGetVariable(void* VariationPtr, const char* name, double* value) +{ + int i; + Variation* var; + + if ((var = (Variation*) VariationPtr) == 0) + return FALSE; + + for (i = 0 ; i < NumVariables; i++) + { + if (strcmp(VarInfo[i].name, name) == 0) + { + *value = (double) VALUE(var, VarInfo[i]); + return TRUE; + } + } + + return FALSE; +} + +DLLIMPORT int PluginVarSetVariable(void* VariationPtr, const char* name, double* value) +{ + int i; + Variation* var; + + if ((var = (Variation*) VariationPtr) == 0) + return FALSE; + + for (i = 0 ; i < NumVariables; i++) + { + if (strcmp(VarInfo[i].name, name) == 0) + { + int v = 0; + + switch (VarInfo[i].type) + { + case REAL : + DOUBLE_LVALUE(var, VarInfo[i]) = fmax(fmin(*value, VarInfo[i].max.d), VarInfo[i].min.d); + break; + case REAL_CYCLIC : + if (*value > VarInfo[i].max.d) + DOUBLE_LVALUE(var, VarInfo[i]) = VarInfo[i].min.d + fmod(*value - VarInfo[i].min.d, VarInfo[i].max.d - VarInfo[i].min.d); + else if (*value < VarInfo[i].min.d) + DOUBLE_LVALUE(var, VarInfo[i]) = VarInfo[i].max.d - fmod(VarInfo[i].max.d - *value, VarInfo[i].max.d - VarInfo[i].min.d); + else + DOUBLE_LVALUE(var, VarInfo[i]) = *value; + break; + case INTEGER : + INT_LVALUE(var, VarInfo[i]) = (int) fmax(fmin(floor(*value + 0.5), VarInfo[i].max.i), VarInfo[i].min.i); + break; + case INTEGER_NONZERO : + v = (int) fmax(fmin(floor(*value + 0.5), VarInfo[i].max.i), VarInfo[i].min.i); + if (v == 0) + v = 1; + INT_LVALUE(var, VarInfo[i]) = v; + break; + } + + return TRUE; + } + } + + return FALSE; +} + +DLLIMPORT int PluginVarResetVariable(void* VariationPtr, const char* name) +{ + int i; + Variation* var; + + if ((var = (Variation*) VariationPtr) == 0) + return FALSE; + + for (i = 0 ; i < NumVariables; i++) + { + if (strcmp(VarInfo[i].name, name) == 0) + { + switch (VarInfo[i].type) + { + case REAL : + case REAL_CYCLIC : + DOUBLE_LVALUE(var, VarInfo[i]) = VarInfo[i].def.d; + break; + case INTEGER : + case INTEGER_NONZERO : + INT_LVALUE(var, VarInfo[i]) = VarInfo[i].def.i; + break; + } + + return TRUE; + } + } + + return FALSE; +} + +DLLIMPORT const char* PluginVarGetVariableNameAt(int index) +{ + if (index >= 0 && index < NumVariables) + return VarInfo[index].name; + + return ""; +} + +/*************** Utility functions ***************/ + +/* Calculate both the sine and cosine of an angle theta (in radians). */ +inline void fsincos(double theta, double* s, double* c) +{ +#if !defined(NO_ASM) && defined(__GNUC__) + __asm__ ( + "fsincos\n\t" + : "=t" (*c), "=u" (*s) + : "0" (theta) + ); +#elif !defined(NO_ASM) && defined(_MSC_VER) + __asm { + fld QWORD PTR theta + fsincos + mov ebx,[c] + fstp QWORD PTR [ebx] + mov ebx,[s] + fstp QWORD PTR [ebx] + } +#else + /* Fall back to individual calls to sin/cos. To enforce this, define + NO_ASM in the plugin code prior to including this header file. */ + *s = sin(theta); + *c = cos(theta); +#endif +} + +// Calculating hyperbolic functions is slow. Calculate exp(u) once and use +// the result to calculate cosh(t) and sinh(t). +// cosh(t) = (exp(t) + exp(-t)) / 2 +// sinh(t) = (exp(t) - exp(-t)) / 2 +inline void sinhcosh(double theta, double* sh, double* ch) +{ + double expt = exp(theta); + double exptinv = 1.0 / expt; + *sh = (expt - exptinv) * 0.5; + *ch = (expt + exptinv) * 0.5; +} + +/* Calculate a random number between 0 and 1. From flam3 source code. */ +inline double random01() +{ + return ((rand() ^ (rand()<<15)) & 0xfffffff) / (double) 0xfffffff; +} + +inline double sqr(double x) +{ + return x*x; +} + +#endif /* _APOPLUGIN_H_ */ + diff --git a/Source/Plugin/example-plugin.c b/Source/Plugin/example-plugin.c new file mode 100644 index 0000000..f16c3a2 --- /dev/null +++ b/Source/Plugin/example-plugin.c @@ -0,0 +1,44 @@ +/* + Apophysis Plugin + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +typedef struct +{ + double example_variable; +} Variables; + +#include "apoplugin.h" + +APO_PLUGIN("example"); +APO_VARIABLES( + VAR_REAL(example_variable, 1.0); +); + +int PluginVarPrepare(Variation* vp) +{ + return TRUE; +} + +int PluginVarCalc(Variation* vp) +{ + // example calculation: + FPx += VVAR * FTx; // Xout = weight * Xin + FPx += VVAR * FTy; // Yout = weight * Yout + TC = fmod(fabs(sqrt(sqr(FTx)+sqr(FTy))), 1.0); // Color [0..1] + + return TRUE; +} diff --git a/Source/Renderer/Render32.pas b/Source/Renderer/Render32.pas deleted file mode 100644 index 6db06c9..0000000 --- a/Source/Renderer/Render32.pas +++ /dev/null @@ -1,452 +0,0 @@ -{ - Apophysis Copyright (C) 2001-2004 Mark Townsend - Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov - Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov - - Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov - Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -} -unit Render32; - -{$define _ASM_} - -interface - -uses - Windows, Classes, Forms, Graphics, Global, - RenderST, RenderTypes, Xform, ControlPoint, - AsmRandom, Hibernation; - -type - TRenderer32 = class(TBaseSTRenderer) - - protected - Buckets: TBucket32Array; - CurrentlySavingHibernationFile: Boolean; - - function GetBits: integer; override; - function GetBucketsPtr: pointer; override; - procedure AllocateBuckets; override; - - procedure ClearBuckets; override; - - protected - procedure IterateBatch; override; - procedure IterateBatchAngle; override; - procedure IterateBatchFX; override; - procedure IterateBatchAngleFX; override; - - // StD functionality - procedure Hibernate(filePath: string); override; - procedure Resume(filePath: string); override; -end; - -// ---------------------------------------------------------------------------- - -type - TRenderer32MM = class(TRenderer32) - - protected - procedure CalcBufferSize; override; - - public - procedure Render; override; - -end; - -implementation - -uses - Math, Sysutils; - -{ TRenderer32 } -/////////////////////////////////////////////////////////////////////////////// -procedure TRenderer32.Hibernate(filePath: string); -var - header: THibHeader; - data: TBucket32Array; - flame: TControlPoint; - handle: File; -begin - PauseTime := Now; - flame := FCP; //TControlPoint.create; - //FCP.Copy(flame); - header := GetHibernationHeader; - data := Buckets; - - HibAllocate(handle, filePath); - HibWriteIntro(handle); - HibWriteGlobals(handle, EFF_NONE, EPL_XYZW, EBP_32); - HibWriteHeader(handle, header); - HibWriteData(handle, header, flame, data, colormap, Progress); - HibWriteOutro(handle); - HibFree(handle); - - //flame.Destroy; -end; -procedure TRenderer32.Resume(filePath: string); -var - header: THibHeader; - flame: TStringList; - flags: EHibFileFlags; - layout: EHibPixelLayout; - bpp: EHibBitsPerPixel; - rel: SmallInt; - valid: Boolean; - handle: File; -begin - HibOpen(handle, filePath); - HibReadIntro(handle, valid); - assert(valid, 'The file had an invalid opening cookie. It may be a wrong format or corrupted.'); - if not valid then exit; - - HibReadGlobals(handle, rel, flags, layout, bpp); - assert(rel = 0, 'The file was created by another version of the renderer.'); - assert(layout = EPL_XYZW, 'Pixel layout is different than XYZW - alternate layouts are not supported by this version.'); - assert(bpp = EBP_32, 'Only 32-bit buffers are supported by this version.'); - if bpp <> EBP_32 then exit; - - HibReadHeader(handle, header); - HibReadData(handle, header, flame, buckets, colormap, Progress); - - FCP := TControlPoint.Create; - FCP.ParseStringList(flame); - SetHibernationHeader(header); - - HibReadOutro(handle, valid); - HibFree(handle); - - assert(valid, 'The file had an invalid closing cookie. It may be a wrong format or corrupted.'); -end; - -/////////////////////////////////////////////////////////////////////////////// -procedure TRenderer32.ClearBuckets; -var - i, j: integer; -begin - for j := 0 to BucketHeight - 1 do - for i := 0 to BucketWidth - 1 do - with buckets[j][i] do begin - Red := 0; - Green := 0; - Blue := 0; - Count := 0; - end; -end; - -/////////////////////////////////////////////////////////////////////////////// -function TRenderer32.GetBits: integer; // obsolete -begin - Result := 0; -end; - -function TRenderer32.GetBucketsPtr: pointer; -begin - Result := Buckets; -end; - -procedure TRenderer32.AllocateBuckets; -begin - SetLength(buckets, BucketHeight, BucketWidth); -end; - -/////////////////////////////////////////////////////////////////////////////// -procedure TRenderer32.IterateBatch; -var - i: integer; - px, py: double; - Bucket: PBucket32; - MapColor: PColorMapColor; - - p, q: TCPPoint; - xf: TXForm; -begin -{$ifndef _ASM_} - p.x := 2 * random - 1; - p.y := 2 * random - 1; - p.c := random; -{$else} -asm - fld1 - call AsmRandExt - fadd st, st - fsub st, st(1) - fstp qword ptr [p.x] - call AsmRandExt - fadd st, st - fsubrp st(1), st - fstp qword ptr [p.y] - call AsmRandExt - fstp qword ptr [p.c] -end; -{$endif} - - try - xf := fcp.xform[0];//random(fcp.NumXForms)]; - for i := 0 to FUSE do begin - xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; - xf.NextPoint(p); - end; - - for i := 0 to SUB_BATCH_SIZE-1 do begin - xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; - xf.NextPoint(p); - - if random >= xf.transOpacity then continue; - - q := p; - fcp.ProjectionFunc(@q); // 3d hack - - px := q.x - camX0; - if (px < 0) or (px > camW) then continue; - py := q.y - camY0; - if (py < 0) or (py > camH) then continue; - - Bucket := @buckets[Round(bhs * py)][Round(bws * px)]; - MapColor := @ColorMap[Round(p.c * 255)]; - - Inc(Bucket.Red, MapColor.Red); - Inc(Bucket.Green, MapColor.Green); - Inc(Bucket.Blue, MapColor.Blue); - Inc(Bucket.Count); - end; - - except - on EMathError do begin - exit; - end; - end; -end; - -procedure TRenderer32.IterateBatchAngle; -var - i: integer; - px, py: double; - Bucket: PBucket32; - MapColor: PColorMapColor; - - p, q: TCPPoint; - xf: TXForm; -begin -{$ifndef _ASM_} - p.x := 2 * random - 1; - p.y := 2 * random - 1; - p.c := random; -{$else} -asm - fld1 - call AsmRandExt - fadd st, st - fsub st, st(1) - fstp qword ptr [p.x] - call AsmRandExt - fadd st, st - fsubrp st(1), st - fstp qword ptr [p.y] - call AsmRandExt - fstp qword ptr [p.c] -end; -{$endif} - - try - xf := fcp.xform[0];//random(fcp.NumXForms)]; - for i := 0 to FUSE do begin - xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; - xf.NextPoint(p); - end; - - for i := 0 to SUB_BATCH_SIZE-1 do begin - xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; - xf.NextPoint(p); - - if random >= xf.transOpacity then continue; - - q := p; - fcp.ProjectionFunc(@q); // 3d hack - - px := q.x * cosa + q.y * sina + rcX; - if (px < 0) or (px > camW) then continue; - py := q.y * cosa - q.x * sina + rcY; - if (py < 0) or (py > camH) then continue; - - Bucket := @buckets[Round(bhs * py)][Round(bws * px)]; - MapColor := @ColorMap[Round(p.c * 255)]; - - Inc(Bucket.Red, MapColor.Red); - Inc(Bucket.Green, MapColor.Green); - Inc(Bucket.Blue, MapColor.Blue); - Inc(Bucket.Count); - end; - - except - on EMathError do begin - exit; - end; - end; -end; - - -procedure TRenderer32.IterateBatchFX; -var - i: integer; - px, py: double; - Bucket: PBucket32; - MapColor: PColorMapColor; - - p, q: TCPPoint; - xf: TXForm; -begin -{$ifndef _ASM_} - p.x := 2 * random - 1; - p.y := 2 * random - 1; - p.c := random; -{$else} -asm - fld1 - call AsmRandExt - fadd st, st - fsub st, st(1) - fstp qword ptr [p.x] - call AsmRandExt - fadd st, st - fsubrp st(1), st - fstp qword ptr [p.y] - call AsmRandExt - fstp qword ptr [p.c] -end; -{$endif} - - try - xf := fcp.xform[0];//random(fcp.NumXForms)]; - for i := 0 to FUSE do begin - xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; - xf.NextPoint(p); - end; - - for i := 0 to SUB_BATCH_SIZE-1 do begin - xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; - xf.NextPoint(p); - - if random >= xf.transOpacity then continue; - - finalXform.NextPointTo(p, q); - - fcp.ProjectionFunc(@q); // 3d hack - - px := q.x - camX0; - if (px < 0) or (px > camW) then continue; - py := q.y - camY0; - if (py < 0) or (py > camH) then continue; - - Bucket := @buckets[Round(bhs * py)][Round(bws * px)]; - MapColor := @ColorMap[Round(q.c * 255)]; - - Inc(Bucket.Red, MapColor.Red); - Inc(Bucket.Green, MapColor.Green); - Inc(Bucket.Blue, MapColor.Blue); - Inc(Bucket.Count); - end; - - except - on EMathError do begin - exit; - end; - end; -end; - -procedure TRenderer32.IterateBatchAngleFX; -var - i: integer; - px, py: double; - Bucket: PBucket32; - MapColor: PColorMapColor; - - p, q: TCPPoint; - xf: TXForm; -begin -{$ifndef _ASM_} - p.x := 2 * random - 1; - p.y := 2 * random - 1; - p.c := random; -{$else} -asm - fld1 - call AsmRandExt - fadd st, st - fsub st, st(1) - fstp qword ptr [p.x] - call AsmRandExt - fadd st, st - fsubrp st(1), st - fstp qword ptr [p.y] - call AsmRandExt - fstp qword ptr [p.c] -end; -{$endif} - - try - xf := fcp.xform[0];//random(fcp.NumXForms)]; - for i := 0 to FUSE do begin - xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; - xf.NextPoint(p); - end; - - for i := 0 to SUB_BATCH_SIZE-1 do begin - xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; - xf.NextPoint(p); - - if random >= xf.transOpacity then continue; - - finalXform.NextPointTo(p, q); - - fcp.ProjectionFunc(@q); // 3d hack - - px := q.x * cosa + q.y * sina + rcX; - if (px < 0) or (px > camW) then continue; - py := q.y * cosa - q.x * sina + rcY; - if (py < 0) or (py > camH) then continue; - - Bucket := @buckets[Round(bhs * py)][Round(bws * px)]; - MapColor := @ColorMap[Round(q.c * 255)]; - - Inc(Bucket.Red, MapColor.Red); - Inc(Bucket.Green, MapColor.Green); - Inc(Bucket.Blue, MapColor.Blue); - Inc(Bucket.Count); - end; - - except - on EMathError do begin - exit; - end; - end; -end; - -// -- { TRenderer32MM } ------------------------------------------------------- - -procedure TRenderer32MM.CalcBufferSize; -begin - CalcBufferSizeMM; -end; - -procedure TRenderer32MM.Render; -begin - RenderMM; -end; - -end. - diff --git a/Source/Renderer/Render32MT.pas b/Source/Renderer/Render32MT.pas deleted file mode 100644 index 7cae6ce..0000000 --- a/Source/Renderer/Render32MT.pas +++ /dev/null @@ -1,198 +0,0 @@ -{ - Apophysis Copyright (C) 2001-2004 Mark Townsend - Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov - Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov - - Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov - Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -} -unit Render32MT; - -interface - -uses - Windows, Forms, Classes, Graphics, Hibernation, - Render, RenderMT, ControlPoint, ImageMaker, RenderTypes; - -type - TRenderer32MT = class(TBaseMTRenderer) - - protected - Buckets: TBucket32Array; - - function GetBits: integer; override; - function GetBucketsPtr: pointer; override; - procedure AllocateBuckets; override; - - procedure ClearBuckets; override; - - // StD functionality - procedure Hibernate(filePath: string); override; - procedure Resume(filePath: string); override; - - public - procedure AddPointsToBuckets(const points: TPointsArray); override; - procedure AddPointsToBucketsAngle(const points: TPointsArray); override; - -end; - -// ---------------------------------------------------------------------------- - -type - TRenderer32MT_MM = class(TRenderer32MT) - - protected - procedure CalcBufferSize; override; - - public - procedure Render; override; - -end; - -implementation - -uses - Math, Sysutils; - -{ TRenderer32MT } - -/////////////////////////////////////////////////////////////////////////////// -procedure TRenderer32MT.Hibernate(filePath: string); -var - header: THibHeader; - data: TBucket32Array; - flame: TControlPoint; - handle: File; -begin - PauseTime := Now; - flame := TControlPoint.create; - FCP.Copy(flame); - header := GetHibernationHeader; - data := Buckets; - - HibAllocate(handle, filePath); - HibWriteIntro(handle); - HibWriteGlobals(handle, EFF_NONE, EPL_XYZW, EBP_32); - HibWriteHeader(handle, header); - HibWriteData(handle, header, flame, data, colormap, Progress); - HibWriteOutro(handle); - HibFree(handle); - - flame.Destroy; -end; -procedure TRenderer32MT.Resume(filePath: string); -begin - -end; - -/////////////////////////////////////////////////////////////////////////////// -function TRenderer32MT.GetBits: integer; // obsolete -begin - Result := 0; -end; - -function TRenderer32MT.GetBucketsPtr: pointer; -begin - Result := Buckets; -end; - -procedure TRenderer32MT.AllocateBuckets; -begin - SetLength(buckets, BucketHeight, BucketWidth); -end; - -/////////////////////////////////////////////////////////////////////////////// -procedure TRenderer32MT.ClearBuckets; -var - i, j: integer; -begin - for j := 0 to BucketHeight - 1 do - for i := 0 to BucketWidth - 1 do - with buckets[j][i] do begin - Red := 0; - Green := 0; - Blue := 0; - Count := 0; - end; -end; - -/////////////////////////////////////////////////////////////////////////////// -procedure TRenderer32MT.AddPointsToBuckets(const points: TPointsArray); -var - i: integer; - px, py: double; - Bucket: PBucket32; - MapColor: PColorMapColor; -begin - for i := SUB_BATCH_SIZE - 1 downto 0 do begin -// if FStop then Exit; - - px := points[i].x - camX0; - if (px < 0) or (px > camW) then continue; - py := points[i].y - camY0; - if (py < 0) or (py > camH) then continue; - - Bucket := @buckets[Round(bhs * py)][Round(bws * px)]; - MapColor := @ColorMap[Round(points[i].c * 255)]; - - Inc(Bucket.Red, MapColor.Red); - Inc(Bucket.Green, MapColor.Green); - Inc(Bucket.Blue, MapColor.Blue); - Inc(Bucket.Count); - end; -end; - -/////////////////////////////////////////////////////////////////////////////// -procedure TRenderer32MT.AddPointsToBucketsAngle(const points: TPointsArray); -var - i: integer; - px, py: double; - Bucket: PBucket32; - MapColor: PColorMapColor; -begin - for i := SUB_BATCH_SIZE - 1 downto 0 do begin -// if FStop then Exit; - - px := points[i].x * cosa + points[i].y * sina + rcX; - if (px < 0) or (px > camW) then continue; - py := points[i].y * cosa - points[i].x * sina + rcY; - if (py < 0) or (py > camH) then continue; - - Bucket := @buckets[Round(bhs * py)][Round(bws * px)]; - MapColor := @ColorMap[Round(points[i].c * 255)]; - - Inc(Bucket.Red, MapColor.Red); - Inc(Bucket.Green, MapColor.Green); - Inc(Bucket.Blue, MapColor.Blue); - Inc(Bucket.Count); - end; -end; - -// -- { TRenderer32MT_MM } ---------------------------------------------------- - -procedure TRenderer32MT_MM.CalcBufferSize; -begin - CalcBufferSizeMM; -end; - -procedure TRenderer32MT_MM.Render; -begin - RenderMM; -end; - -end. - diff --git a/Source/Renderer/RenderMT.pas b/Source/Renderer/RenderMT.pas deleted file mode 100644 index ce62959..0000000 --- a/Source/Renderer/RenderMT.pas +++ /dev/null @@ -1,190 +0,0 @@ -{ - Apophysis Copyright (C) 2001-2004 Mark Townsend - Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov - Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov - - Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov - Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -} -unit RenderMT; - -interface - -uses - Windows, Forms, Classes, Graphics, - Render, Controlpoint, ImageMaker, BucketFillerthread, RenderTypes, Translation; - -type - TBaseMTRenderer = class(TBaseRenderer) - - private - batchcounter: Integer; - - WorkingThreads: array of TBucketFillerThread; - CriticalSection: TRTLCriticalSection; - - function NewThread: TBucketFillerThread; - - protected - procedure Prepare; override; - procedure SetPixels; override; - - procedure AddPointsToBuckets(const points: TPointsArray); virtual; abstract; - procedure AddPointsToBucketsAngle(const points: TPointsArray); virtual; abstract; - - public - procedure Stop; override; - procedure BreakRender; override; - - procedure Pause; override; - procedure UnPause; override; - - end; - -implementation - -uses - Math, Sysutils; - -{ TBaseMTRenderer } - -/////////////////////////////////////////////////////////////////////////////// -procedure TBaseMTRenderer.SetPixels; -var - i: integer; - nSamples: Int64; - bc : integer; -begin - if FNumSlices > 1 then - TimeTrace(Format(TextByKey('common-trace-rendering-multipleslices'), [FSlice + 1, FNumSlices])) - else - TimeTrace(TextByKey('common-trace-rendering-oneslice')); - - nSamples := Round(sample_density * NrSlices * BucketSize / (oversample * oversample)); - FNumBatches := Round(nSamples / (fcp.nbatches * SUB_BATCH_SIZE)); - if FNumBatches = 0 then FNumBatches := 1; - FMinBatches := Round(FNumBatches * FMinDensity / fcp.sample_density); - - batchcounter := 1; - Randomize; - - InitializeCriticalSection(CriticalSection); - - SetLength(WorkingThreads, NumThreads); - for i := 0 to NumThreads - 1 do - WorkingThreads[i] := NewThread; - - for i := 0 to NumThreads - 1 do - WorkingThreads[i].Resume; - - bc := 1; - while (FStop = 0) and (bc <= FNumBatches) do begin - sleep(250); - try - EnterCriticalSection(CriticalSection); - - Progress(batchcounter / FNumBatches); - bc := batchcounter; - finally - LeaveCriticalSection(CriticalSection); - end; - end; - - for i := 0 to High(WorkingThreads) do begin - WorkingThreads[i].Terminate; - WorkingThreads[i].WaitFor; - WorkingThreads[i].Free; - end; - SetLength(WorkingThreads, 0); - - fcp.actual_density := fcp.actual_density + - fcp.sample_density * BatchCounter / FNumBatches; // actual quality of incomplete render - FNumBatches := BatchCounter; - - DeleteCriticalSection(CriticalSection); - Progress(1); -end; - -/////////////////////////////////////////////////////////////////////////////// -procedure TBaseMTRenderer.Prepare; -begin - fcp.Prepare; -end; - -/////////////////////////////////////////////////////////////////////////////// -procedure TBaseMTRenderer.Stop; -var - i: integer; -begin - for i := 0 to High(WorkingThreads) do - WorkingThreads[i].Terminate; - //SetLength(WorkingThreads, 0); //? - - inherited; // FStop := 1; -end; - -procedure TBaseMTRenderer.BreakRender; -var - i: integer; -begin - inherited; // FStop := -1; - - {if BatchCounter < FMinBatches then exit;} - - for i := 0 to High(WorkingThreads) do - WorkingThreads[i].Terminate; - //SetLength(WorkingThreads, 0); //? -end; - -procedure TBaseMTRenderer.Pause; -var - i: integer; -begin - inherited; - - for i := 0 to High(WorkingThreads) do - WorkingThreads[i].Suspend; -end; - -procedure TBaseMTRenderer.UnPause; -var - i: integer; -begin - inherited; - - for i := 0 to High(WorkingThreads) do - WorkingThreads[i].Resume; -end; - -/////////////////////////////////////////////////////////////////////////////// -function TBaseMTRenderer.NewThread: TBucketFillerThread; -begin - Result := TBucketFillerThread.Create(fcp); - assert(Result<>nil); - - if FCP.FAngle = 0 then - Result.AddPointsProc := self.AddPointsToBuckets - else - Result.AddPointsProc := self.AddPointsToBucketsAngle; - - Result.CriticalSection := CriticalSection; - Result.Nrbatches := FNumBatches; - Result.batchcounter := @batchcounter; -end; - -end. - diff --git a/Source/Renderer/RenderST.pas b/Source/Renderer/RenderST.pas deleted file mode 100644 index ce12e4f..0000000 --- a/Source/Renderer/RenderST.pas +++ /dev/null @@ -1,132 +0,0 @@ -{ - Apophysis Copyright (C) 2001-2004 Mark Townsend - Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov - Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov - - Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov - Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -} - -unit RenderST; - -interface - -uses - Windows, Classes, Forms, Graphics, ImageMaker, - Render, RenderTypes, Xform, ControlPoint, Translation; - -type - TBatchProc = procedure of object; - -type - TBaseSTRenderer = class(TBaseRenderer) - - protected - PropTable: array[0..PROP_TABLE_SIZE] of TXform; - finalXform: TXform; - UseFinalXform: boolean; - - procedure Prepare; override; - procedure SetPixels; override; - - procedure IterateBatch; virtual; abstract; - procedure IterateBatchAngle; virtual; abstract; - procedure IterateBatchFX; virtual; abstract; - procedure IterateBatchAngleFX; virtual; abstract; - end; - -implementation - -uses - Math, Sysutils; - -{ TBaseSTRenderer } - -/////////////////////////////////////////////////////////////////////////////// -procedure TBaseSTRenderer.Prepare; -var - i, n: Integer; - propsum: double; - LoopValue: double; - j: integer; - TotValue: double; -begin - totValue := 0; - n := fcp.NumXforms; - assert(n > 0); - - finalXform := fcp.xform[n]; - finalXform.Prepare; - useFinalXform := fcp.FinalXformEnabled and fcp.HasFinalXform; - - fcp.Prepare; -end; - -/////////////////////////////////////////////////////////////////////////////// -procedure TBaseSTRenderer.SetPixels; -var - i: integer; - nsamples: int64; - IterateBatchProc: procedure of object; -begin - if FNumSlices > 1 then - TimeTrace(Format(TextByKey('common-trace-rendering-multipleslices'), [FSlice + 1, FNumSlices])) - else - TimeTrace(TextByKey('common-trace-rendering-oneslice')); - - Randomize; - - if FCP.FAngle = 0 then begin - if UseFinalXform then - IterateBatchProc := IterateBatchFX - else - IterateBatchProc := IterateBatch; - end - else begin - if UseFinalXform then - IterateBatchProc := IterateBatchAngleFX - else - IterateBatchProc := IterateBatchAngle; - end; - - NSamples := Round(sample_density * NrSlices * bucketSize / (oversample * oversample)); - FNumBatches := Round(nsamples / (fcp.nbatches * SUB_BATCH_SIZE)); - if FNumBatches = 0 then FNumBatches := 1; - FMinBatches := Round(FNumBatches * FMinDensity / fcp.sample_density); - if FMinBatches = 0 then FMinBatches := 1; - - for i := 0 to FNumBatches-1 do begin - if FStop <> 0 then begin -// if (FStop <> 0) or (i >= FMinBatches) then begin //? - fcp.actual_density := fcp.actual_density + - fcp.sample_density * i / FNumBatches; // actual quality of incomplete render - FNumBatches := i; - exit; - end; - - if ((i and $1F) = 0) then Progress(i / FNumBatches); - - IterateBatchProc; - Inc(FBatch); - end; - - fcp.actual_density := fcp.actual_density + fcp.sample_density; - - Progress(1); -end; - -end. diff --git a/Source/Renderer/BucketFillerThread.pas b/Source/Rendering/BucketFillerThread.pas similarity index 97% rename from Source/Renderer/BucketFillerThread.pas rename to Source/Rendering/BucketFillerThread.pas index c4acc3f..308a177 100644 --- a/Source/Renderer/BucketFillerThread.pas +++ b/Source/Rendering/BucketFillerThread.pas @@ -26,8 +26,7 @@ interface uses - Classes, Windows, - ControlPoint, Render, XForm, RenderTypes; + Classes, Windows, ControlPoint, RenderingInterface, XForm; type TBucketFillerThread = class(TThread) diff --git a/Source/Renderer/ImageMaker.pas b/Source/Rendering/ImageMaker.pas similarity index 88% rename from Source/Renderer/ImageMaker.pas rename to Source/Rendering/ImageMaker.pas index 3d5c09a..34cd514 100644 --- a/Source/Renderer/ImageMaker.pas +++ b/Source/Rendering/ImageMaker.pas @@ -26,7 +26,7 @@ interface uses - Windows, Graphics, ControlPoint, RenderTypes, PngImage; + Windows, Graphics, ControlPoint, RenderingCommon, PngImage, Bezier; type TPalette = record logpal : TLogPalette; @@ -57,20 +57,11 @@ TImageMaker = class FBucketHeight: integer; FBucketWidth: integer; - - //FBuckets64: TBucket64Array; - //FBuckets48: TBucket48Array; - FBuckets32: TBucket32Array; - //FBuckets32f: TBucket32fArray; - + FBuckets: TBucketArray; FOnProgress: TOnProgress; - - FGetBucket: function(x, y: integer): TBucket32 of object; - //function GetBucket64(x, y: integer): TBucket64; - //function GetBucket48(x, y: integer): TBucket64; - function GetBucket32(x, y: integer): TBucket32; - //function GetBucket32f(x, y: integer): TBucket64; - function SafeGetBucket(x, y: integer): TBucket32; + FGetBucket: function(x, y: integer): TBucket of object; + function GetBucket(x, y: integer): TBucket; + function SafeGetBucket(x, y: integer): TBucket; procedure CreateFilter; procedure InitDE; @@ -174,7 +165,7 @@ procedure TImageMaker.CreateFilter; adjust := 1.0; setLength(FFilter, FFilterSize, FFilterSize); - if fcp.enable_de then InitDE; + if fcp.enable_de and false then InitDE; for i := 0 to FFilterSize - 1 do begin for j := 0 to FFilterSize - 1 do begin @@ -356,12 +347,12 @@ procedure TImageMaker.Init; /////////////////////////////////////////////////////////////////////////////// procedure TImageMaker.SetBucketData(const Buckets: pointer; BucketWidth, BucketHeight: integer; bits: integer); begin - FBuckets32 := TBucket32Array(Buckets); + FBuckets := TBucketArray(Buckets); FBucketWidth := BucketWidth; FBucketHeight := BucketHeight; - FGetBucket := GetBucket32; + FGetBucket := GetBucket; end; /////////////////////////////////////////////////////////////////////////////// @@ -390,6 +381,7 @@ procedure TImageMaker.CreateImage(YOffset: integer); filterValue: double; // filterpos: Integer; lsa: array[0..1024] of double; + csa: array[0..3] of array[0..256] of double; sample_density: extended; gutter_width: integer; k1, k2: double; @@ -403,9 +395,11 @@ procedure TImageMaker.CreateImage(YOffset: integer); scf:boolean; scfact : double; acc : integer; + avg, fac: double; + curvesSet: boolean; - GetBucket: function(x, y: integer): TBucket32 of object; - bucket: TBucket32; + GetBucket: function(x, y: integer): TBucket of object; + bucket: TBucket; bx, by: integer; label zero_alpha; begin @@ -419,7 +413,8 @@ procedure TImageMaker.CreateImage(YOffset: integer); notvib := 256 - vib; if fcp.gamma_threshold <> 0 then - funcval := power(fcp.gamma_threshold, gamma - 1); { / fcp.gamma_threshold; } + funcval := power(fcp.gamma_threshold, gamma - 1) { / fcp.gamma_threshold; } + else funcval := 0; bgi[0] := round(fcp.background[0]); bgi[1] := round(fcp.background[1]); @@ -431,6 +426,16 @@ procedure TImageMaker.CreateImage(YOffset: integer); zero_BG.green := 0; zero_BG.blue := 0; + curvesSet := true; + for i := 0 to 3 do + curvesSet := curvesSet and ( + ((fcp.curvePoints[i][0].x = 0) and (fcp.curvePoints[i][0].y = 0)) and + ((fcp.curvePoints[i][1].x = 0) and (fcp.curvePoints[i][1].y = 0)) and + ((fcp.curvePoints[i][2].x = 1) and (fcp.curvePoints[i][2].y = 1)) and + ((fcp.curvePoints[i][3].x = 1) and (fcp.curvePoints[i][3].y = 1)) + ); + curvesSet := not curvesSet; + gutter_width := FBucketwidth - FOversample * fcp.Width; // gutter_width := 2 * ((25 - Foversample) div 2); if(FFilterSize <= gutter_width div 2) then // filter too big when 'post-processing' ? @@ -446,9 +451,17 @@ procedure TImageMaker.CreateImage(YOffset: integer); area := FBitmap.Width * FBitmap.Height / (fcp.ppux * fcp.ppuy); k2 := (FOversample * FOversample) / (fcp.Contrast * area * fcp.White_level * sample_density); - lsa[0] := 0; - for i := 1 to 1024 do begin - lsa[i] := (k1 * log10(1 + fcp.White_level * i * k2)) / (fcp.White_level * i); + csa[0][0] := 0; csa[1][0] := 0; csa[2][0] := 0; csa[3][0] := 0; + for i := 0 to 1024 do begin + if i = 0 then lsa[0] := 0 + else lsa[i] := (k1 * log10(1 + fcp.White_level * i * k2)) / (fcp.White_level * i); + + if i <= 256 then begin + csa[0][i] := BezierFunc(i / 256.0, fcp.curvePoints[0], fcp.curveWeights[0]) * 256; + csa[1][i] := BezierFunc(i / 256.0, fcp.curvePoints[1], fcp.curveWeights[1]) * 256; + csa[2][i] := BezierFunc(i / 256.0, fcp.curvePoints[2], fcp.curveWeights[2]) * 256; + csa[3][i] := BezierFunc(i / 256.0, fcp.curvePoints[3], fcp.curveWeights[3]) * 256; + end; end; ls := 0; @@ -480,7 +493,7 @@ procedure TImageMaker.CreateImage(YOffset: integer); bucket := GetBucket(bx + jj, by + ii); if bucket.count < 1024 then - ls := lsa[bucket.Count] + ls := lsa[Round(bucket.Count)] else ls := (k1 * log10(1 + fcp.White_level * bucket.count * k2)) / (fcp.White_level * bucket.count); @@ -498,7 +511,7 @@ procedure TImageMaker.CreateImage(YOffset: integer); end else begin bucket := GetBucket(bx, by); if bucket.count < 1024 then - ls := lsa[bucket.count] / PREFILTER_WHITE + ls := lsa[Round(bucket.count)] / PREFILTER_WHITE else ls := (k1 * log10(1 + fcp.White_level * bucket.count * k2)) / (fcp.White_level * bucket.count) / PREFILTER_WHITE; @@ -550,7 +563,7 @@ procedure TImageMaker.CreateImage(YOffset: integer); end; if bucket.count < 1024 then - ls := lsa[bucket.Count] + ls := lsa[Round(bucket.Count)] else if bucket.count = 0 then ls := 0 else @@ -607,7 +620,10 @@ procedure TImageMaker.CreateImage(YOffset: integer); bi := Round(ls * fp[2]); end; - // ignoring BG color in transparent renders... + // ignoring BG color in transparent renders.. + if (ri >= 0) and (ri <= 256) and (curvesSet) then ri := Round(csa[1][Round(csa[0][ri])]); + if (gi >= 0) and (gi <= 256) and (curvesSet) then gi := Round(csa[2][Round(csa[0][gi])]); + if (bi >= 0) and (bi <= 256) and (curvesSet) then bi := Round(csa[3][Round(csa[0][bi])]); ri := (ri * 255) div ai; // ai > 0 ! if (ri < 0) then ri := 0 @@ -659,6 +675,10 @@ procedure TImageMaker.CreateImage(YOffset: integer); bi := Round(ls * fp[2]); end; + if (ri >= 0) and (ri <= 256) and (curvesSet) then ri := Round(csa[1][Round(csa[0][ri])]); + if (gi >= 0) and (gi <= 256) and (curvesSet) then gi := Round(csa[2][Round(csa[0][gi])]); + if (bi >= 0) and (bi <= 256) and (curvesSet) then bi := Round(csa[3][Round(csa[0][bi])]); + ri := ri + (ia * bgi[0]) shr 8; if (ri < 0) then ri := 0 else if (ri > 255) then ri := 255; @@ -717,8 +737,8 @@ procedure TImageMaker.SaveImage(FileName: String); end; //else Exception.CreateFmt('Unexpected value of PNGTransparency [%d]', [PNGTransparency]); - if (FParameters <> '') then - PngObject.AddtEXt('Parameters', FParameters); + {if (FParameters <> '') then + PngObject.AddtEXt('Parameters', FParameters); } PngObject.SaveToFile(FileName); except pngError := true; @@ -766,7 +786,7 @@ function TImageMaker.GetTransparentImage: TPngObject; Result := TPngObject.Create; Result.Assign(FBitmap); - if fcp.Transparency then begin + if ((fcp <> nil) and fcp.Transparency) then begin Result.CreateAlpha; for i:= 0 to FAlphaBitmap.Height - 1 do begin rowbm := PByteArray(FAlphaBitmap.scanline[i]); @@ -780,14 +800,9 @@ function TImageMaker.GetTransparentImage: TPngObject; /////////////////////////////////////////////////////////////////////////////// -(*function TImageMaker.GetBucket64(x, y: integer): TBucket64; -begin - Result := FBuckets64[y][x]; -end; *) - -function TImageMaker.GetBucket32(x, y: integer): TBucket32; +function TImageMaker.GetBucket(x, y: integer): TBucket; begin - with FBuckets32[y][x] do begin + with FBuckets[y][x] do begin Result.Red := Red; Result.Green := Green; Result.Blue := Blue; @@ -795,27 +810,7 @@ function TImageMaker.GetBucket32(x, y: integer): TBucket32; end; end; -(*function TImageMaker.GetBucket32f(x, y: integer): TBucket64; -begin - with FBuckets32f[y][x] do begin - Result.Red := round(Red); - Result.Green := round(Green); - Result.Blue := round(Blue); - Result.Count := round(Count); - end; -end; - -function TImageMaker.GetBucket48(x, y: integer): TBucket64; -begin - with FBuckets48[y][x] do begin - Result.Red := int64(rl) or ( int64(rh) shl 32 ); - Result.Green := int64(gl) or ( int64(gh) shl 32 ); - Result.Blue := int64(bl) or ( int64(bh) shl 32 ); - Result.Count := int64(cl) or ( int64(ch) shl 32 ); - end; -end; *) - -function TImageMaker.SafeGetBucket(x, y: integer): TBucket32; +function TImageMaker.SafeGetBucket(x, y: integer): TBucket; begin if x < 0 then x := 0 else if x >= FBucketWidth then x := FBucketWidth-1; @@ -830,7 +825,7 @@ procedure TImageMaker.GetBucketStats(var Stats: TBucketStats); var bucketpos: integer; x, y: integer; - b: TBucket32; + b: TBucket; begin with Stats do begin MaxR := 0; @@ -846,7 +841,7 @@ procedure TImageMaker.GetBucketStats(var Stats: TBucketStats); MaxG := max(MaxG, b.Green); MaxB := max(MaxB, b.Blue); MaxA := max(MaxA, b.Count); - Inc(TotalA, b.Count); + TotalA := TotalA + b.Count end; end; end; diff --git a/Source/Renderer/RenderThread.pas b/Source/Rendering/RenderThread.pas similarity index 86% rename from Source/Renderer/RenderThread.pas rename to Source/Rendering/RenderThread.pas index 1194b2b..761d529 100644 --- a/Source/Renderer/RenderThread.pas +++ b/Source/Rendering/RenderThread.pas @@ -26,9 +26,9 @@ interface uses Classes, Windows, Messages, Graphics, - ControlPoint, Render, - Global, RenderTypes, PngImage, - Render32, Render32MT; + ControlPoint, RenderingInterface, + Global, RenderingCommon, PngImage, + RenderingImplementation; //Disabled: @@ -52,12 +52,16 @@ TRenderThread = class(TThread) FBitsPerSample: integer; FMinDensity: double; FOutput: TStrings; + FExportBuffer: boolean; procedure CreateRenderer; function GetNrSlices: integer; function GetSlice: integer; procedure SetBitsPerSample(const bits: Integer); + function GetExportBuffer: boolean; + procedure SetExportBuffer(value: boolean); + procedure Trace(const str: string); public @@ -108,6 +112,9 @@ TRenderThread = class(TThread) write FOutput; property MinDensity: double write FMinDensity; + property ExportBuffer: boolean + read GetExportBuffer + write SetExportBuffer; end; implementation @@ -128,6 +135,19 @@ destructor TRenderThread.Destroy; inherited; end; +function TRenderThread.GetExportBuffer: boolean; +begin + if assigned(FRenderer) then + Result := FRenderer.ExportBuffer + else Result := FExportBuffer; +end; +procedure TRenderThread.SetExportBuffer(value: boolean); +begin + if assigned(FRenderer) then + FRenderer.ExportBuffer := value; + FExportBuffer := value; +end; + /////////////////////////////////////////////////////////////////////////////// function TRenderThread.GetImage: TBitmap; begin @@ -147,6 +167,7 @@ function TRenderThread.GetTransparentImage: TPngObject; /////////////////////////////////////////////////////////////////////////////// procedure TRenderThread.SetCP(CP: TControlPoint); begin + FCP := CP.Clone; end; @@ -172,48 +193,24 @@ procedure TRenderThread.CreateRenderer; if NrThreads <= 1 then begin if MaxMem = 0 then begin - (*case FBitsPerSample of - 0: FRenderer := TRenderer32.Create; - 1: FRenderer := TRenderer32f.Create; - 2: FRenderer := TRenderer48.Create; - //3: FRenderer := TRenderer64.Create; - end; *) - FRenderer := TRenderer32.Create; + FRenderer := TRenderWorkerST.Create; end else begin - (*case FBitsPerSample of - 0: FRenderer := TRenderer32MM.Create; - 1: FRenderer := TRenderer32fMM.Create; - 2: FRenderer := TRenderer48MM.Create; - //3: FRenderer := TRenderer64MM.Create; - end;*) - FRenderer := TRenderer32MM.Create; + FRenderer := TRenderWorkerST_MM.Create; FRenderer.MaxMem := MaxMem; end; end else begin if MaxMem = 0 then begin - (*case FBitsPerSample of - 0: FRenderer := TRenderer32MT.Create; - 1: FRenderer := TRenderer32fMT.Create; - 2: FRenderer := TRenderer48MT.Create; - //3: FRenderer := TRenderer64MT.Create; - end; *) - FRenderer := TRenderer32MT.Create; + FRenderer := TRenderWorkerMT.Create; end else begin - (*case FBitsPerSample of - 0: FRenderer := TRenderer32MT_MM.Create; - 1: FRenderer := TRenderer32fMT_MM.Create; - 2: FRenderer := TRenderer48MT_MM.Create; - //3: FRenderer := TRenderer64MT_MM.Create; - end; *) - FRenderer := TRenderer32MT_MM.Create; + FRenderer := TRenderWorkerMT_MM.Create; FRenderer.MaxMem := MaxMem; end; FRenderer.NumThreads := NrThreads; end; + FRenderer.ExportBuffer := FExportbuffer; FRenderer.SetCP(FCP); -// FRenderer.compatibility := compatibility; FRenderer.MinDensity := FMinDensity; FRenderer.OnProgress := FOnProgress; FRenderer.Output := FOutput; @@ -257,8 +254,12 @@ procedure TRenderThread.Execute; /////////////////////////////////////////////////////////////////////////////// procedure TRenderThread.Terminate; begin - if assigned(FRenderer) then - FRenderer.Stop; + try + if assigned(FRenderer) then + FRenderer.Stop; + except on EAccessViolation do + // nothing + end; WaitForMore := false; @@ -288,14 +289,14 @@ procedure TRenderThread.BreakRender; procedure TRenderThread.HibernateRender(filePath: string); begin if assigned(FRenderer) then - FRenderer.HibernateRender(filePath); + FRenderer.Hibernate(filePath); end; procedure TRenderThread.ResumeFromHibernation(filePath: string); begin if assigned(FRenderer) then FRenderer.Stop; - FRenderer.ResumeFromHibernation(filePath); + FRenderer.Resume(filePath); FRenderer.UnPause; end; diff --git a/Source/Renderer/RenderTypes.pas b/Source/Rendering/RenderingCommon.pas similarity index 50% rename from Source/Renderer/RenderTypes.pas rename to Source/Rendering/RenderingCommon.pas index 0116967..19fd470 100644 --- a/Source/Renderer/RenderTypes.pas +++ b/Source/Rendering/RenderingCommon.pas @@ -20,77 +20,51 @@ along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. } - -unit RenderTypes; +unit RenderingCommon; interface - -uses SysUtils, Windows, Translation, Classes; - type + TOnFinish = procedure of object; TOnProgress = procedure(prog: double) of object; - TOnOutput = procedure(s: string) of object; - -type - TColorMapColor = Record + {$ifdef Apo7X64} + TBucket = Record Red, Green, - Blue: integer; + Blue, + Count: Double; end; - PColorMapColor = ^TColorMapColor; - TColorMapArray = array[0..255] of TColorMapColor; - - TBucket32 = Record + {$else} + TBucket = Record Red, Green, Blue, - Count: Longword; + Count: Single; end; - PBucket32 = ^TBucket32; - TBucket32Array = array of array of TBucket32; + {$endif} + PBucket = ^TBucket; + TBucketArray = array of array of TBucket; + TZBuffer = array of array of double; -const - MAX_FILTER_WIDTH = 25; - -const - SizeOfBucket: array[0..3] of byte = (16, 16, 24, 32); - -type TBucketStats = record MaxR, MaxG, MaxB, MaxA, - TotalA: int64; + TotalA: double; end; - -function TimeToString(t: TDateTime): string; + +procedure TrimWorkingSet; implementation +uses Windows; -function TimeToString(t: TDateTime): string; +procedure TrimWorkingSet; var - n: integer; + hProcess: THandle; begin - n := Trunc(t); - Result := ''; - if n > 0 then begin - Result := Result + Format(' %d ' + TextByKey('common-days'), [n]); - //if n <> 1 then Result := Result + 's'; - end; - t := t * 24; - n := Trunc(t) mod 24; - if n > 0 then begin - Result := Result + Format(' %d ' + TextByKey('common-hours'), [n]); - //if n <> 1 then Result := Result + 's'; - end; - t := t * 60; - n := Trunc(t) mod 60; - if n > 0 then begin - Result := Result + Format(' %d ' + TextByKey('common-minutes'), [n]); - //if n <> 1 then Result := Result + 's'; + hProcess := OpenProcess(PROCESS_SET_QUOTA, false, GetCurrentProcessId); + + try SetProcessWorkingSetSize(hProcess, $FFFFFFFF, $FFFFFFFF); + finally CloseHandle(hProcess); end; - t := t * 60; - t := t - (Trunc(t) div 60) * 60; - Result := Result + Format(' %.2f ' + TextByKey('common-seconds'), [t]); end; end. diff --git a/Source/Rendering/RenderingImplementation.pas b/Source/Rendering/RenderingImplementation.pas new file mode 100644 index 0000000..4cf709c --- /dev/null +++ b/Source/Rendering/RenderingImplementation.pas @@ -0,0 +1,718 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} +unit RenderingImplementation; + +{$ifdef Apo7X64} +{$else} + {$define _ASM_} +{$endif} + +interface + +uses +{$ifdef Apo7X64} +{$else} +AsmRandom, +{$endif} + Windows, Classes, Forms, Graphics, Global, + RenderingInterface, Xform, Math, Translation, + Binary, RenderingCommon, ControlPoint, Sysutils, + BucketFillerThread; + +type + TBatchProc = procedure of object; + TRenderWorkerST = class(TBaseRenderer) + + protected + PropTable: array[0..PROP_TABLE_SIZE] of TXform; + finalXform: TXform; + UseFinalXform: boolean; + + procedure Prepare; override; + procedure SetPixels; override; + + protected + procedure IterateBatch; + procedure IterateBatchAngle; + procedure IterateBatchFX; + procedure IterateBatchAngleFX; +end; + +type + TRenderWorkerMT = class(TBaseRenderer) + + protected + batchcounter: Integer; + WorkingThreads: array of TBucketFillerThread; + CriticalSection: TRTLCriticalSection; + + function NewThread: TBucketFillerThread; + procedure Prepare; override; + procedure SetPixels; override; + + protected + procedure AddPointsToBuckets(const points: TPointsArray); + procedure AddPointsToBucketsAngle(const points: TPointsArray); + + public + procedure Stop; override; + procedure BreakRender; override; + + procedure Pause; override; + procedure UnPause; override; +end; + +type + TRenderWorkerST_MM = class(TRenderWorkerST) + protected + procedure CalcBufferSize; override; + public + procedure Render; override; + +end; + +type + TRenderWorkerMT_MM = class(TRenderWorkerMT) + protected + procedure CalcBufferSize; override; + public + procedure Render; override; +end; + +// ---------------------------------------------------------------------------- + +implementation + +//////////////////////////////////////////////////////////////////////////////// +// PREPARE +//////////////////////////////////////////////////////////////////////////////// +procedure TRenderWorkerST.Prepare; +var + i, n: Integer; + propsum: double; + LoopValue: double; + j: integer; + TotValue: double; +begin + totValue := 0; + n := fcp.NumXforms; + assert(n > 0); + + finalXform := fcp.xform[n]; + finalXform.Prepare; + useFinalXform := fcp.FinalXformEnabled and fcp.HasFinalXform; + + fcp.Prepare; +end; +procedure TRenderWorkerMT.Prepare; +begin + fcp.Prepare; +end; + +//////////////////////////////////////////////////////////////////////////////// +// SETPIXELS +//////////////////////////////////////////////////////////////////////////////// +procedure TRenderWorkerST.SetPixels; +var + i: integer; + nsamples: int64; + IterateBatchProc: procedure of object; +begin + if FNumSlices > 1 then + TimeTrace(Format(TextByKey('common-trace-rendering-multipleslices'), [FSlice + 1, FNumSlices])) + else + TimeTrace(TextByKey('common-trace-rendering-oneslice')); + + Randomize; + + if FCP.FAngle = 0 then begin + if UseFinalXform then + IterateBatchProc := IterateBatchFX + else + IterateBatchProc := IterateBatch; + end + else begin + if UseFinalXform then + IterateBatchProc := IterateBatchAngleFX + else + IterateBatchProc := IterateBatchAngle; + end; + + NSamples := Round(sample_density * NrSlices * bucketSize / (oversample * oversample)); + FNumBatches := Round(nsamples / (fcp.nbatches * SUB_BATCH_SIZE)); + if FNumBatches = 0 then FNumBatches := 1; + + FMinBatches := Round(FNumBatches * FMinDensity / fcp.sample_density); + if FMinBatches = 0 then FMinBatches := 1; + + for i := 0 to FNumBatches-1 do begin + if FStop <> 0 then begin + fcp.actual_density := fcp.actual_density + fcp.sample_density * i / FNumBatches; + FNumBatches := i; + exit; + end; + + if ((i and $1F) = 0) then Progress(i / FNumBatches); + + IterateBatchProc; + Inc(FBatch); + end; + + fcp.actual_density := fcp.actual_density + fcp.sample_density; + + Progress(1); +end; +procedure TRenderWorkerMT.SetPixels; +var + i: integer; + nSamples: Int64; + bc : integer; +begin + if FNumSlices > 1 then + TimeTrace(Format(TextByKey('common-trace-rendering-multipleslices'), [FSlice + 1, FNumSlices])) + else + TimeTrace(TextByKey('common-trace-rendering-oneslice')); + + nSamples := Round(sample_density * NrSlices * BucketSize / (oversample * oversample)); + FNumBatches := Round(nSamples / (fcp.nbatches * SUB_BATCH_SIZE)); + if FNumBatches = 0 then FNumBatches := 1; + FMinBatches := Round(FNumBatches * FMinDensity / fcp.sample_density); + + batchcounter := 1; + Randomize; + + InitializeCriticalSection(CriticalSection); + + SetLength(WorkingThreads, NumThreads); + for i := 0 to NumThreads - 1 do + WorkingThreads[i] := NewThread; + + for i := 0 to NumThreads - 1 do + WorkingThreads[i].Resume; + + bc := 1; + while (FStop = 0) and (bc <= FNumBatches) do begin + sleep(250); + try + EnterCriticalSection(CriticalSection); + + Progress(batchcounter / FNumBatches); + bc := batchcounter; + finally + LeaveCriticalSection(CriticalSection); + end; + end; + + for i := 0 to High(WorkingThreads) do begin + WorkingThreads[i].Terminate; + WorkingThreads[i].WaitFor; + WorkingThreads[i].Free; + end; + SetLength(WorkingThreads, 0); + + fcp.actual_density := fcp.actual_density + + fcp.sample_density * BatchCounter / FNumBatches; // actual quality of incomplete render + FNumBatches := BatchCounter; + + DeleteCriticalSection(CriticalSection); + Progress(1); +end; + +//////////////////////////////////////////////////////////////////////////////// +// MM OVERRIDES +//////////////////////////////////////////////////////////////////////////////// +procedure TRenderWorkerST_MM.CalcBufferSize; +begin + CalcBufferSizeMM; +end; +procedure TRenderWorkerST_MM.Render; +begin + RenderMM; +end; +procedure TRenderWorkerMT_MM.CalcBufferSize; +begin + CalcBufferSizeMM; +end; +procedure TRenderWorkerMT_MM.Render; +begin + RenderMM; +end; + +//////////////////////////////////////////////////////////////////////////////// +// BATCH ITERATION +//////////////////////////////////////////////////////////////////////////////// +procedure TRenderWorkerST.IterateBatch; +var + i: integer; + px, py: double; + Bucket: PBucket; + ZBufPos: PDouble; + MapColor: PColorMapColor; + + ix, iy: integer; + BmpColor: TColor; + + p, q: TCPPoint; + xf: TXForm; +begin +{$ifndef _ASM_} + p.x := 2 * random - 1; + p.y := 2 * random - 1; + p.c := random; +{$else} +asm + fld1 + call AsmRandExt + fadd st, st + fsub st, st(1) + fstp qword ptr [p.x] + call AsmRandExt + fadd st, st + fsubrp st(1), st + fstp qword ptr [p.y] + call AsmRandExt + fstp qword ptr [p.c] +end; +{$endif} + + try + xf := fcp.xform[0]; + for i := 0 to FUSE do begin + xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; + xf.NextPoint(p); + end; + + for i := 0 to SUB_BATCH_SIZE-1 do begin + xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; + xf.NextPoint(p); + + if random >= xf.transOpacity then continue; + + q := p; + fcp.ProjectionFunc(@q); // 3d hack + + px := q.x - camX0; + if (px < 0) or (px > camW) then continue; + py := q.y - camY0; + if (py < 0) or (py > camH) then continue; + + Bucket := @buckets[Round(bhs * py)][Round(bws * px)]; + MapColor := @ColorMap[Round(p.c * 255)]; + {$ifdef ENABLEZBUF} + ZBufPos := @zbuffer[Round(bhs * py)][Round(bws * px)]; + if (q.z < ZBufPos^) then + begin + ZBufPos^ := q.z; + Bucket.Red := Bucket.Red + MapColor.Red; + Bucket.Green := Bucket.Green + MapColor.Green; + Bucket.Blue := Bucket.Blue + MapColor.Blue; + Bucket.Count := Bucket.Count + 1; + end; + {$else} + Bucket.Red := Bucket.Red + MapColor.Red; + Bucket.Green := Bucket.Green + MapColor.Green; + Bucket.Blue := Bucket.Blue + MapColor.Blue; + Bucket.Count := Bucket.Count + 1; + {$endif} + end; + + except + on EMathError do begin + exit; + end; + end; +end; +procedure TRenderWorkerST.IterateBatchAngle; +var + i: integer; + px, py: double; + Bucket: PBucket; + MapColor: PColorMapColor; + ZBufPos: PDouble; + ix, iy: integer; + BmpColor: TColor; + + p, q: TCPPoint; + xf: TXForm; +begin +{$ifndef _ASM_} + p.x := 2 * random - 1; + p.y := 2 * random - 1; + p.c := random; +{$else} +asm + fld1 + call AsmRandExt + fadd st, st + fsub st, st(1) + fstp qword ptr [p.x] + call AsmRandExt + fadd st, st + fsubrp st(1), st + fstp qword ptr [p.y] + call AsmRandExt + fstp qword ptr [p.c] +end; +{$endif} + + try + xf := fcp.xform[0]; + for i := 0 to FUSE do begin + xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; + xf.NextPoint(p); + end; + + for i := 0 to SUB_BATCH_SIZE-1 do begin + xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; + xf.NextPoint(p); + + if random >= xf.transOpacity then continue; + + q := p; + fcp.ProjectionFunc(@q); + + px := q.x * cosa + q.y * sina + rcX; + if (px < 0) or (px > camW) then continue; + py := q.y * cosa - q.x * sina + rcY; + if (py < 0) or (py > camH) then continue; + + Bucket := @buckets[Round(bhs * py)][Round(bws * px)]; + MapColor := @ColorMap[Round(p.c * 255)]; + + {$ifdef ENABLEZBUF} + ZBufPos := @zbuffer[Round(bhs * py)][Round(bws * px)]; + if (q.z < ZBufPos^) then + begin + ZBufPos^ := q.z; + Bucket.Red := Bucket.Red + MapColor.Red; + Bucket.Green := Bucket.Green + MapColor.Green; + Bucket.Blue := Bucket.Blue + MapColor.Blue; + Bucket.Count := Bucket.Count + 1; + end; + {$else} + Bucket.Red := Bucket.Red + MapColor.Red; + Bucket.Green := Bucket.Green + MapColor.Green; + Bucket.Blue := Bucket.Blue + MapColor.Blue; + Bucket.Count := Bucket.Count + 1; + {$endif} + end; + + except + on EMathError do begin + exit; + end; + end; +end; +procedure TRenderWorkerST.IterateBatchFX; +var + i: integer; + px, py: double; + Bucket: PBucket; + MapColor: PColorMapColor; + ZbufPos: PDouble; + ix, iy: integer; + BmpColor: TColor; + + p, q: TCPPoint; + xf: TXForm; +begin +{$ifndef _ASM_} + p.x := 2 * random - 1; + p.y := 2 * random - 1; + p.c := random; +{$else} +asm + fld1 + call AsmRandExt + fadd st, st + fsub st, st(1) + fstp qword ptr [p.x] + call AsmRandExt + fadd st, st + fsubrp st(1), st + fstp qword ptr [p.y] + call AsmRandExt + fstp qword ptr [p.c] +end; +{$endif} + + try + xf := fcp.xform[0]; + for i := 0 to FUSE do begin + xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; + xf.NextPoint(p); + end; + + for i := 0 to SUB_BATCH_SIZE-1 do begin + xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; + xf.NextPoint(p); + + if random >= xf.transOpacity then continue; + + finalXform.NextPointTo(p, q); + fcp.ProjectionFunc(@q); + + px := q.x - camX0; + if (px < 0) or (px > camW) then continue; + py := q.y - camY0; + if (py < 0) or (py > camH) then continue; + + Bucket := @buckets[Round(bhs * py)][Round(bws * px)]; + MapColor := @ColorMap[Round(q.c * 255)]; + + {$ifdef ENABLEZBUF} + ZBufPos := @zbuffer[Round(bhs * py)][Round(bws * px)]; + if (q.z < ZBufPos^) then + begin + ZBufPos^ := q.z; + Bucket.Red := Bucket.Red + MapColor.Red; + Bucket.Green := Bucket.Green + MapColor.Green; + Bucket.Blue := Bucket.Blue + MapColor.Blue; + Bucket.Count := Bucket.Count + 1; + end; + {$else} + Bucket.Red := Bucket.Red + MapColor.Red; + Bucket.Green := Bucket.Green + MapColor.Green; + Bucket.Blue := Bucket.Blue + MapColor.Blue; + Bucket.Count := Bucket.Count + 1; + {$endif} + end; + + except + on EMathError do begin + exit; + end; + end; +end; +procedure TRenderWorkerST.IterateBatchAngleFX; +var + i: integer; + px, py: double; + Bucket: PBucket; + MapColor: PColorMapColor; + ZBufPos: PDouble; + ix, iy: integer; + BmpColor: TColor; + + p, q: TCPPoint; + xf: TXForm; +begin +{$ifndef _ASM_} + p.x := 2 * random - 1; + p.y := 2 * random - 1; + p.c := random; +{$else} +asm + fld1 + call AsmRandExt + fadd st, st + fsub st, st(1) + fstp qword ptr [p.x] + call AsmRandExt + fadd st, st + fsubrp st(1), st + fstp qword ptr [p.y] + call AsmRandExt + fstp qword ptr [p.c] +end; +{$endif} + + try + xf := fcp.xform[0]; + for i := 0 to FUSE do begin + xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; + xf.NextPoint(p); + end; + + for i := 0 to SUB_BATCH_SIZE-1 do begin + xf := xf.PropTable[Random(PROP_TABLE_SIZE)]; + xf.NextPoint(p); + + if random >= xf.transOpacity then continue; + + finalXform.NextPointTo(p, q); + fcp.ProjectionFunc(@q); + + px := q.x * cosa + q.y * sina + rcX; + if (px < 0) or (px > camW) then continue; + py := q.y * cosa - q.x * sina + rcY; + if (py < 0) or (py > camH) then continue; + + Bucket := @buckets[Round(bhs * py)][Round(bws * px)]; + MapColor := @ColorMap[Round(q.c * 255)]; + + {$ifdef ENABLEZBUF} + ZBufPos := @zbuffer[Round(bhs * py)][Round(bws * px)]; + if (q.z < ZBufPos^) then + begin + ZBufPos^ := q.z; + Bucket.Red := Bucket.Red + MapColor.Red; + Bucket.Green := Bucket.Green + MapColor.Green; + Bucket.Blue := Bucket.Blue + MapColor.Blue; + Bucket.Count := Bucket.Count + 1; + end; + {$else} + Bucket.Red := Bucket.Red + MapColor.Red; + Bucket.Green := Bucket.Green + MapColor.Green; + Bucket.Blue := Bucket.Blue + MapColor.Blue; + Bucket.Count := Bucket.Count + 1; + {$endif} + end; + + except + on EMathError do begin + exit; + end; + end; +end; +procedure TRenderWorkerMT.AddPointsToBuckets(const points: TPointsArray); +var + i: integer; + px, py: double; + Bucket: PBucket; + ZBufPos: PDouble; + MapColor: PColorMapColor; +begin + for i := SUB_BATCH_SIZE - 1 downto 0 do begin + px := points[i].x - camX0; + if (px < 0) or (px > camW) then continue; + py := points[i].y - camY0; + if (py < 0) or (py > camH) then continue; + + Bucket := @buckets[Round(bhs * py)][Round(bws * px)]; + MapColor := @ColorMap[Round(points[i].c * 255)]; + + if random >= points[i].o then continue; + + {$ifdef ENABLEZBUF} + ZBufPos := @zbuffer[Round(bhs * py)][Round(bws * px)]; + if (points[i].z < ZBufPos^) then + begin + ZBufPos^ := points[i].z; + Bucket.Red := Bucket.Red + MapColor.Red; + Bucket.Green := Bucket.Green + MapColor.Green; + Bucket.Blue := Bucket.Blue + MapColor.Blue; + Bucket.Count := Bucket.Count + 1; + end; + {$else} + Bucket.Red := Bucket.Red + MapColor.Red; + Bucket.Green := Bucket.Green + MapColor.Green; + Bucket.Blue := Bucket.Blue + MapColor.Blue; + Bucket.Count := Bucket.Count + 1; + {$endif} + end; +end; +procedure TRenderWorkerMT.AddPointsToBucketsAngle(const points: TPointsArray); +var + i: integer; + px, py: double; + Bucket: PBucket; + MapColor: PColorMapColor; + ZBufPos: PDouble; +begin + for i := SUB_BATCH_SIZE - 1 downto 0 do begin + px := points[i].x * cosa + points[i].y * sina + rcX; + if (px < 0) or (px > camW) then continue; + py := points[i].y * cosa - points[i].x * sina + rcY; + if (py < 0) or (py > camH) then continue; + + Bucket := @buckets[Round(bhs * py)][Round(bws * px)]; + MapColor := @ColorMap[Round(points[i].c * 255)]; + + if random >= points[i].o then continue; + + {$ifdef ENABLEZBUF} + ZBufPos := @zbuffer[Round(bhs * py)][Round(bws * px)]; + if (points[i].z < ZBufPos^) then + begin + ZBufPos^ := points[i].z; + Bucket.Red := Bucket.Red + MapColor.Red; + Bucket.Green := Bucket.Green + MapColor.Green; + Bucket.Blue := Bucket.Blue + MapColor.Blue; + Bucket.Count := Bucket.Count + 1; + end; + {$else} + Bucket.Red := Bucket.Red + MapColor.Red; + Bucket.Green := Bucket.Green + MapColor.Green; + Bucket.Blue := Bucket.Blue + MapColor.Blue; + Bucket.Count := Bucket.Count + 1; + {$endif} + end; +end; + +//////////////////////////////////////////////////////////////////////////////// +// THREADING +//////////////////////////////////////////////////////////////////////////////// +procedure TRenderWorkerMT.Stop; +var + i: integer; +begin + for i := 0 to High(WorkingThreads) do + WorkingThreads[i].Terminate; + + inherited; +end; +procedure TRenderWorkerMT.BreakRender; +var + i: integer; +begin + inherited; + + for i := 0 to High(WorkingThreads) do + WorkingThreads[i].Terminate; +end; +procedure TRenderWorkerMT.Pause; +var + i: integer; +begin + inherited; + + for i := 0 to High(WorkingThreads) do + WorkingThreads[i].Suspend; +end; +procedure TRenderWorkerMT.UnPause; +var + i: integer; +begin + inherited; + + for i := 0 to High(WorkingThreads) do + WorkingThreads[i].Resume; +end; +function TRenderWorkerMT.NewThread: TBucketFillerThread; +begin + Result := TBucketFillerThread.Create(fcp); + assert(Result<>nil); + + if FCP.FAngle = 0 then + Result.AddPointsProc := self.AddPointsToBuckets + else + Result.AddPointsProc := self.AddPointsToBucketsAngle; + + Result.CriticalSection := CriticalSection; + Result.Nrbatches := FNumBatches; + Result.batchcounter := @batchcounter; +end; + +end. + diff --git a/Source/Renderer/Render.pas b/Source/Rendering/RenderingInterface.pas similarity index 68% rename from Source/Renderer/Render.pas rename to Source/Rendering/RenderingInterface.pas index f036f04..035bd6e 100644 --- a/Source/Renderer/Render.pas +++ b/Source/Rendering/RenderingInterface.pas @@ -20,13 +20,13 @@ along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. } -unit Render; +unit RenderingInterface; interface uses - Windows, Graphics, Classes, Hibernation, - Controlpoint, RenderTypes, ImageMaker, PngImage, Translation; + Windows, Graphics, Classes, RenderingCommon, + Controlpoint, ImageMaker, PngImage, Translation; /////////////////////////////////////////////////////////////////////////////// // @@ -34,12 +34,64 @@ interface // /////////////////////////////////////////////////////////////////////////////// +const + opRendering: integer = 0; + opSampling: integer = 1; + opHibernating: integer = 2; + +type + TOnOutput = procedure(s: string) of object; + TOnOperation = procedure(op: integer) of object; + TCopyBufferCallback = procedure(tgr: Pointer; x, y: integer) of object; + +type + TColorMapColor = Record + Red, + Green, + Blue: + + {$ifdef Apo7X64} + double + {$else} + single + {$endif}; + end; + PColorMapColor = ^TColorMapColor; + TColorMapArray = array[0..255] of TColorMapColor; + + TPoint3D = Record + X, + Y, + Z, + W: Double; + end; + TPoint3DArray = array of TPoint3D; + +const + MAX_FILTER_WIDTH = 25; + +//const + //SizeOfBucket: array[0..3] of byte = (32, 32, 32, 32); + +function TimeToString(t: TDateTime): string; + type TBaseRenderer = class private FOnProgress: TOnProgress; + FOnOperation: TOnOperation; + FCopyBuffer: TCopyBufferCallback; strOutput: TStrings; + protected + Buckets: TBucketArray; + ZBuffer: TZBuffer; + + procedure AllocateBuckets; + procedure ClearBuckets; + procedure SetBucketsPtr(ptr: pointer); + function GetBucketsPtr: pointer; + protected camX0, camX1, camY0, camY1, // camera bounds camW, camH, // camera sizes @@ -77,9 +129,13 @@ TBaseRenderer = class FMinBatches: integer; FRenderOver: boolean; - RenderTime, PauseTime: TDateTime; + FBufferPath: string; + FDoExportBuffer: boolean; + + StartTime, RenderTime, PauseTime: TDateTime; procedure Progress(value: double); + procedure Operation(op: integer); procedure SetMinDensity(const q: double); @@ -91,31 +147,23 @@ TBaseRenderer = class procedure CalcBufferSize; virtual; procedure CalcBufferSizeMM; - - function GetBits: integer; virtual; abstract; - function GetBucketsPtr: pointer; virtual; abstract; + procedure InitBuffers; - procedure AllocateBuckets; virtual; abstract; - procedure ClearBuckets; virtual; abstract; procedure RenderMM; procedure Trace(const str: string); procedure TimeTrace(const str: string); - - // StD functionality - procedure Hibernate(filePath: string); virtual; abstract; - procedure Resume(filePath: string); virtual; abstract; - - function GetHibernationHeader: THibHeader; - procedure SetHibernationHeader(header: THibHeader); - public constructor Create; virtual; destructor Destroy; override; + procedure Hibernate(filePath: string); + procedure Resume(filePath: string); + procedure SetCP(CP: TControlPoint); procedure Render; virtual; - + procedure ProcessBuffer(density: double); + function GetImage: TBitmap; virtual; procedure GetImageAndDelete(target:tBitmap); virtual; function GetTransparentImage: TPngObject; @@ -124,8 +172,6 @@ TBaseRenderer = class procedure Stop; virtual; procedure BreakRender; virtual; - procedure HibernateRender(filePath: string); - procedure ResumeFromHibernation(filePath: string); procedure Pause; virtual; procedure UnPause; virtual; procedure SetThreadPriority(p: TThreadPriority); virtual; @@ -136,9 +182,13 @@ TBaseRenderer = class procedure ShowBigStats; procedure ShowSmallStats; + property CopyBufferCallback: TCopyBufferCallback + write FCopyBuffer; property OnProgress: TOnProgress // read FOnProgress write FOnProgress; + property OnOperation: TOnOperation + write FOnOperation; property MaxMem : integer read FMaxMem write FMaxMem; @@ -155,6 +205,16 @@ TBaseRenderer = class write SetMinDensity; property RenderMore: boolean write FRenderOver; + property Batch: integer + read FBatch; + property NrBatches: integer + read FNumBatches; + property BufferPath: string + read FBufferPath + write FBufferPath; + property ExportBuffer: boolean + read FDoExportBuffer + write FDoExportBuffer; end; /////////////////////////////////////////////////////////////////////////////// @@ -169,35 +229,213 @@ TRenderer = class FRenderer: TBaseRenderer; FOnProgress: TOnProgress; + FOnOperation: TOnOperation; + FCopyBuffer: TCopyBufferCallback; FCP: TControlPoint; FMaxMem: int64; + FBufferPath: string; + FNrThreads: integer; + + function GetSlice: integer; + function GetNrSlices: integer; + function GetBatch: integer; + function GetNrBatches: integer; + function GetNrThreads: integer; + + procedure SetNrThreads(v: integer); public destructor Destroy; override; procedure SetCP(CP: TControlPoint); procedure Render; + procedure ProcessBuffer(density: double); function GetImage: TBitmap; procedure GetImageAndDelete(target: TBitmap); + function GetTransparentImage: TPngObject; procedure Stop; + procedure IntermediateSample(imgmkr: TImageMaker); + + property CopyBufferCallback: TCopyBufferCallback + read FCopyBuffer + write FCopyBuffer; property OnProgress: TOnProgress read FOnProgress write FOnProgress; + property OnOperation: TOnOperation + read FOnOperation + write FOnOperation; + + property Slice: integer + read GetSlice; + property NrSlices: integer + read GetNrSlices; + + property Batch: integer + read GetBatch; + property NrBatches: integer + read GetNrBatches; + property NrThreads: integer + read FNrThreads + write FNrThreads; + property BufferPath: string + read FBufferPath + write FBufferPath; + + procedure Hibernate(fileName: string); end; implementation uses Math, SysUtils, Forms, - Render32; + RenderingImplementation, + Binary, Global; /////////////////////////////////////////////////////////////////////////////// // // { TBaseRenderer } // /////////////////////////////////////////////////////////////////////////////// +procedure TBaseRenderer.Hibernate(filePath: string); +begin + // todo +end; +procedure TBaseRenderer.Resume(filePath: string); +begin + // todo +end; +procedure TBaseRenderer.CalcBufferSizeMM; +begin + oversample := fcp.spatial_oversample; + gutter_width := (FImageMaker.GetFilterSize - oversample) div 2; + BucketHeight := oversample * image_height + 2 * gutter_width; + Bucketwidth := oversample * image_width + 2 * gutter_width; + BucketSize := BucketWidth * BucketHeight; +end; +procedure TBaseRenderer.RenderMM; +const + Dividers: array[0..15] of integer = (1, 2, 3, 4, 5, 6, 7, 8, 10, 16, 20, 32, 64, 128, 256, 512); +var + ApproxMemory, MaxMemory: int64; + i: integer; + zoom_scale, center_base, center_y: double; + t: TDateTime; +begin + FStop := 0; //False; + + image_Center_X := fcp.center[0]; + image_Center_Y := fcp.center[1]; + + image_Height := fcp.Height; + image_Width := fcp.Width; + oversample := fcp.spatial_oversample; + + // entered memory - imagesize + MaxMemory := FMaxMem * 1024 * 1024 - 4 * image_Height * int64(image_Width); + + if (SingleBuffer) then + ApproxMemory := 16 * sqr(oversample) * image_Height * int64(image_Width) + else + ApproxMemory := 32 * sqr(oversample) * image_Height * int64(image_Width); + + assert(MaxMemory > 0); + if MaxMemory <= 0 then exit; + + FNumSlices := 1 + ApproxMemory div MaxMemory; + + if FNumSlices > Dividers[High(Dividers)] then begin + for i := High(Dividers) downto 0 do begin + if image_height <> (image_height div dividers[i]) * dividers[i] then begin + FNumSlices := dividers[i]; + break; + end; + end; + end else begin + for i := 0 to High(Dividers) do begin + if image_height <> (image_height div dividers[i]) * dividers[i] then + continue; + if FNumSlices <= dividers[i] then begin + FNumSlices := dividers[i]; + break; + end; + end; + end; + + FImageMaker.SetCP(FCP); + FImageMaker.Init; + + fcp.height := fcp.height div FNumSlices; + center_y := fcp.center[1]; + zoom_scale := power(2.0, fcp.zoom); + center_base := center_y - ((FNumSlices - 1) * fcp.height) / (2 * fcp.pixels_per_unit * zoom_scale); + + image_height := fcp.Height; + image_Width := fcp.Width; + + InitBuffers; + CreateColorMap; + Prepare; + + RenderTime := 0; + for i := 0 to FNumSlices - 1 do begin + if FStop <> 0 then Exit; + + FSlice := i; + fcp.center[1] := center_base + fcp.height * slice / (fcp.pixels_per_unit * zoom_scale); + CreateCameraMM; + ClearBuckets; + fcp.actual_density := 0; + + t := Now; + SetPixels; + RenderTime := RenderTime + (Now - t); + + if FStop = 0 then begin + TimeTrace(TextByKey('common-trace-creating-simple')); + FImageMaker.OnProgress := FOnProgress; + FImageMaker.CreateImage(Slice * fcp.height); + end; + end; + + fcp.height := fcp.height * FNumSlices; +end; +procedure TBaseRenderer.AllocateBuckets; +var + i, j: integer; +begin + SetLength(buckets, BucketHeight, BucketWidth); + SetLength(zbuffer, BucketHeight, BucketWidth); + + for i := 0 to BucketHeight - 1 do + for j := 0 to BucketWidth - 1 do + begin + zbuffer[i, j] := 10e10; + end; +end; +procedure TBaseRenderer.ClearBuckets; +var + i, j: integer; +begin + for j := 0 to BucketHeight - 1 do + for i := 0 to BucketWidth - 1 do + with buckets[j][i] do begin + Red := 0; + Green := 0; + Blue := 0; + Count := 0; + end; +end; +procedure TBaseRenderer.SetBucketsPtr(ptr: pointer); +begin + Buckets := TBucketArray(ptr); +end; +function TBaseRenderer.GetBucketsPtr: pointer; +begin + Result := Buckets; +end; constructor TBaseRenderer.Create; begin @@ -216,12 +454,49 @@ destructor TBaseRenderer.Destroy; begin FImageMaker.Free; + SetLength(buckets, 1, 1); + SetLength(zbuffer, 1, 1); + if assigned(FCP) then FCP.Free; + TrimWorkingSet; + inherited; end; +procedure TBaseRenderer.Operation(op: integer); +begin + if assigned(FOnOperation) then + FOnOperation(op); +end; +function TRenderer.GetSlice: integer; +begin + Result := FRenderer.Slice; +end; +function TRenderer.GetNrSlices: integer; +begin + Result := FRenderer.NrSlices; +end; + +function TRenderer.GetBatch: integer; +begin + Result := FRenderer.Batch; +end; +function TRenderer.GetNrBatches: integer; +begin + Result := FRenderer.NrBatches; +end; + +function TRenderer.GetNrThreads: integer; +begin + Result := FRenderer.NumThreads; +end; +procedure TRenderer.SetNrThreads(v: integer); +begin + FRenderer.NumThreads := v; +end; + /////////////////////////////////////////////////////////////////////////////// procedure TBaseRenderer.SetCP(CP: TControlPoint); begin @@ -282,34 +557,6 @@ procedure TBaseRenderer.BreakRender; FStop := -1; end; -procedure TBaseRenderer.HibernateRender(filePath: string); -begin - Hibernate(filePath); - FHibernated := true; - FStop := 1; -end; - -procedure TBaseRenderer.ResumeFromHibernation(filePath: string); -begin - Resume(filePath); -end; - -function TBaseRenderer.GetHibernationHeader: THibHeader; -begin - Result.ActualDensity := - fcp.actual_density + fcp.sample_density * FBatch / FNumBatches; - Result.Size2D.X := BucketWidth; - Result.Size2D.Y := BucketHeight; - Result.Size := BucketSize; - Result.RenderTime := RenderTime; - Result.PauseTime := Now; -end; - -procedure TBaseRenderer.SetHibernationHeader(header: THibHeader); -begin - -end; - /////////////////////////////////////////////////////////////////////////////// procedure TBaseRenderer.Progress(value: double); begin @@ -335,57 +582,6 @@ function TBaseRenderer.Hibernated: boolean; Result := FHibernated; end; -/////////////////////////////////////////////////////////////////////////////// -procedure TBaseRenderer.ShowBigStats; -var - Stats: TBucketStats; - TotalSamples: int64; - - Rbits, Gbits, Bbits, Abits: double; -begin - if not assigned(strOutput) then exit; - - strOutput.Add(''); - if NrSlices = 1 then - strOutput.Add(TextByKey('common-statistics-title-oneslice')) - else - strOutput.Add(TextByKey('common-statistics-title-multipleslices')); // not really useful :-\ - - TotalSamples := int64(FNumBatches) * SUB_BATCH_SIZE; // * fcp.nbatches ? - if TotalSamples <= 0 then begin - //strOutput.Add(' Nothing to talk about!'); // normally shouldn't happen - exit; - end; - strOutput.Add(Format(' ' + TextByKey('common-statistics-maxpossiblebits'), [8 + log2(TotalSamples)])); - FImageMaker.GetBucketStats(Stats); - with Stats do begin - if MaxR > 0 then Rbits := log2(MaxR) else Rbits := 0; - if MaxG > 0 then Gbits := log2(MaxG) else Gbits := 0; - if MaxB > 0 then Bbits := log2(MaxB) else Bbits := 0; - if MaxA > 0 then Abits := log2(MaxA) else Abits := 0; - strOutput.Add(Format(' ' + TextByKey('common-statistics-maxred'), [Rbits])); - strOutput.Add(Format(' ' + TextByKey('common-statistics-maxgreen'), [Gbits])); - strOutput.Add(Format(' ' + TextByKey('common-statistics-maxblue'), [Bbits])); - strOutput.Add(Format(' ' + TextByKey('common-statistics-maxcounter'), [Abits])); - strOutput.Add(Format(' ' + TextByKey('common-statistics-pointhitratio'), [100.0*(TotalA/TotalSamples)])); - if RenderTime > 0 then // hmm - strOutput.Add(Format(' ' + TextByKey('common-statistics-averagespeed'), [TotalSamples / (RenderTime * 24 * 60 * 60)])); - strOutput.Add(' ' + TextByKey('common-statistics-purerenderingtime') + TimeToString(RenderTime)); - end; -end; - -procedure TBaseRenderer.ShowSmallStats; -var - TotalSamples: int64; -begin - if not assigned(strOutput) then exit; - - TotalSamples := int64(FNumBatches) * SUB_BATCH_SIZE; // * fcp.nbatches ? - if RenderTime > 0 then // hmm - strOutput.Add(Format(' ' + TextByKey('common-statistics-averagespeed'), [TotalSamples / (RenderTime * 24 * 60 * 60)])); - strOutput.Add(' ' + TextByKey('common-statistics-purerenderingtime') + TimeToString(RenderTime)); -end; - /////////////////////////////////////////////////////////////////////////////// function TBaseRenderer.GetImage: TBitmap; begin @@ -416,10 +612,8 @@ procedure TRenderer.GetImageAndDelete(target:tBitmap); function TBaseRenderer.GetTransparentImage: TPngObject; begin if FStop > 0 then begin - //Trace('WARNING: Trying to get unprepared image!?'); + // shouldn't happen. and if it does...WTF? Result := nil; -// FImageMaker.OnProgress := OnProgress; -// FImageMaker.CreateImage; end else Result := FImageMaker.GetTransparentImage; @@ -480,7 +674,6 @@ procedure TBaseRenderer.CreateCamera; sample_density := fcp.sample_density * scale * scale; ppux := fcp.pixels_per_unit * scale; ppuy := fcp.pixels_per_unit * scale; - // todo field stuff shift := 0; corner_x := fcp.center[0] - fcp.Width / ppux / 2.0; @@ -574,52 +767,55 @@ procedure TBaseRenderer.CalcBufferSize; BucketSize := BucketWidth * BucketHeight; end; -procedure TBaseRenderer.CalcBufferSizeMM; -begin - oversample := fcp.spatial_oversample; - gutter_width := (FImageMaker.GetFilterSize - oversample) div 2; - BucketHeight := oversample * image_height + 2 * gutter_width; - Bucketwidth := oversample * image_width + 2 * gutter_width; - BucketSize := BucketWidth * BucketHeight; -end; - /////////////////////////////////////////////////////////////////////////////// procedure TBaseRenderer.InitBuffers; var - bits: integer; error_string : string; begin error_string := TextByKey('common-trace-notenoughmemory'); - bits := GetBits; CalcBufferSize; try - TimeTrace(Format(TextByKey('common-trace-allocating'), [BucketSize * SizeOfBucket[bits] / 1048576])); + FStop := 0; + TrimWorkingSet; + if SingleBuffer then + TimeTrace(Format(TextByKey('common-trace-allocating'), [BucketSize * 16 / 1048576])) + else + TimeTrace(Format(TextByKey('common-trace-allocating'), [BucketSize * 32 / 1048576])); - AllocateBuckets; // SetLength(buckets, BucketHeight, BucketWidth); + AllocateBuckets; except on EOutOfMemory do begin if Assigned(strOutput) then - strOutput.Add(error_string) - else - Application.MessageBox(PAnsiChar(error_string), 'Apophysis', 48); - BucketWidth := 0; - BucketHeight := 0; - FStop := 1; + strOutput.Add(error_string); + FStop := 1; + TrimWorkingSet; exit; end; end; // share the buffer with imagemaker - FImageMaker.SetBucketData(GetBucketsPtr, BucketWidth, BucketHeight, bits); + FImageMaker.SetBucketData(GetBucketsPtr, BucketWidth, BucketHeight, 64); end; /////////////////////////////////////////////////////////////////////////////// +procedure TRenderer.IntermediateSample(imgmkr: TImageMaker); +begin + FCP.actual_density := FCP.sample_density * FRenderer.FBatch / FRenderer.FNumBatches; + imgmkr.SetCP(FCP); + imgmkr.Init; + imgmkr.SetBucketData(FRenderer.GetBucketsPtr, FRenderer.BucketWidth, FRenderer.BucketHeight, 64); + imgmkr.CreateImage; +end; + procedure TBaseRenderer.Render; begin - if fcp.NumXForms <= 0 then exit; + if fcp.NumXForms <= 0 then + begin + exit; + end; FStop := 0; //False; FImageMaker.SetCP(FCP); @@ -634,6 +830,9 @@ procedure TBaseRenderer.Render; CreateCamera; if not FRenderOver then ClearBuckets; + Operation(opRendering); + + StartTime := Now; RenderTime := Now; SetPixels; RenderTime := Now - RenderTime; @@ -644,95 +843,84 @@ procedure TBaseRenderer.Render; else TimeTrace(Format(TextByKey('common-trace-creating-detailed'), [fcp.actual_density])); + if (FBufferPath <> '') then begin + Operation(opHibernating); + Hibernate(FBufferPath); + end; + + Operation(opSampling); FImageMaker.OnProgress := FOnProgress; FImageMaker.CreateImage; end; end; -/////////////////////////////////////////////////////////////////////////////// -procedure TBaseRenderer.RenderMM; -const - Dividers: array[0..15] of integer = (1, 2, 3, 4, 5, 6, 7, 8, 10, 16, 20, 32, 64, 128, 256, 512); +procedure TBaseRenderer.ProcessBuffer(density: double); var - ApproxMemory, MaxMemory: int64; - i: integer; - zoom_scale, center_base, center_y: double; - t: TDateTime; + nsamples: int64; + x, y: integer; + bucket : TBucket; + ptr: TBucketArray; begin + if fcp.NumXForms <= 0 then exit; FStop := 0; //False; - image_Center_X := fcp.center[0]; - image_Center_Y := fcp.center[1]; - - image_Height := fcp.Height; - image_Width := fcp.Width; - oversample := fcp.spatial_oversample; + FImageMaker.SetCP(FCP); + FImageMaker.Init; - // entered memory - imagesize - MaxMemory := FMaxMem * 1024 * 1024 - 4 * image_Height * int64(image_Width); + InitBuffers; + if FStop <> 0 then exit; // memory allocation error? - ApproxMemory := SizeOfBucket[GetBits] * sqr(oversample) * image_Height * int64(image_Width); + CreateColorMap; + Prepare; - assert(MaxMemory > 0); - if MaxMemory <= 0 then exit; + CreateCamera; + if not FRenderOver then ClearBuckets; - FNumSlices := 1 + ApproxMemory div MaxMemory; + Operation(opSampling); - if FNumSlices > Dividers[High(Dividers)] then begin - for i := High(Dividers) downto 0 do begin - if image_height <> (image_height div dividers[i]) * dividers[i] then begin - FNumSlices := dividers[i]; - break; - end; - end; - end else begin - for i := 0 to High(Dividers) do begin - if image_height <> (image_height div dividers[i]) * dividers[i] then - continue; - if FNumSlices <= dividers[i] then begin - FNumSlices := dividers[i]; - break; - end; + StartTime := Now; + RenderTime := Now; + //////////////// + Randomize; + + NSamples := Round(sample_density * NrSlices * bucketSize / (oversample * oversample)); + FNumBatches := Round(nsamples / (fcp.nbatches * SUB_BATCH_SIZE)); + if FNumBatches = 0 then FNumBatches := 1; + FMinBatches := Round(FNumBatches * FMinDensity / fcp.sample_density); + if FMinBatches = 0 then FMinBatches := 1; + + ptr := TBucketArray(GetBucketsPtr); + if (assigned(FCopyBuffer)) then begin + for y := 0 to BucketHeight - 1 do + for x := 0 to BucketWidth - 1 do + begin + FCopyBuffer(@bucket, x, y); + ptr[y, x].red := bucket.red; + ptr[y, x].green := bucket.green; + ptr[y, x].blue := bucket.blue; + ptr[y, x].count := bucket.count; end; - end; - FImageMaker.SetCP(FCP); - FImageMaker.Init; - - fcp.height := fcp.height div FNumSlices; - center_y := fcp.center[1]; - zoom_scale := power(2.0, fcp.zoom); - center_base := center_y - ((FNumSlices - 1) * fcp.height) / (2 * fcp.pixels_per_unit * zoom_scale); - - image_height := fcp.Height; - image_Width := fcp.Width; - - InitBuffers; - CreateColorMap; - Prepare; + end; + FBatch := FNumBatches; - RenderTime := 0; - for i := 0 to FNumSlices - 1 do begin - if FStop <> 0 then Exit; + fcp.actual_density := density; - FSlice := i; - fcp.center[1] := center_base + fcp.height * slice / (fcp.pixels_per_unit * zoom_scale); - CreateCameraMM; - ClearBuckets; - fcp.actual_density := 0; + Progress(0); + //////////////// + RenderTime := Now - RenderTime; - t := Now; - SetPixels; - RenderTime := RenderTime + (Now - t); + if FStop <= 0 then begin + if fcp.sample_density = fcp.actual_density then + TimeTrace(TextByKey('common-trace-creating-simple')) + else + TimeTrace(Format(TextByKey('common-trace-creating-detailed'), [fcp.actual_density])); - if FStop = 0 then begin - TimeTrace(TextByKey('common-trace-creating-simple')); - FImageMaker.OnProgress := FOnProgress; - FImageMaker.CreateImage(Slice * fcp.height); - end; + //Operation(opSampling); + FImageMaker.OnProgress := FOnProgress; + FImageMaker.CreateImage; end; - fcp.height := fcp.height * FNumSlices; end; /////////////////////////////////////////////////////////////////////////////// @@ -764,21 +952,44 @@ procedure TRenderer.SetCP(CP: TControlPoint); end; /////////////////////////////////////////////////////////////////////////////// +procedure TRenderer.ProcessBuffer(density: double); +begin + if assigned(FRenderer) then + FRenderer.Free; + + assert(Fmaxmem=0); + if FNrThreads <= 1 then + FRenderer := TRenderWorkerST.Create + else begin + FRenderer := TRenderWorkerMT.Create; + FRenderer.NumThreads := FNrThreads; + end; + + FRenderer.SetCP(FCP); + FRenderer.OnProgress := FOnProgress; + FRenderer.OnOperation := FOnOperation; + FRenderer.CopyBufferCallback := FCopyBuffer; + FRenderer.BufferPath := ''; + FRenderer.ProcessBuffer(density); +end; procedure TRenderer.Render; begin if assigned(FRenderer) then FRenderer.Free; assert(Fmaxmem=0); -// if FMaxMem = 0 then begin - FRenderer := TRenderer32.Create; -// end else begin -// FRenderer := TRenderer32MM.Create; -// FRenderer.MaxMem := FMaxMem -// end; + if FNrThreads <= 1 then + FRenderer := TRenderWorkerST.Create + + else begin + FRenderer := TRenderWorkerMT.Create; + FRenderer.NumThreads := FNrThreads; + end; FRenderer.SetCP(FCP); FRenderer.OnProgress := FOnProgress; + FRenderer.OnOperation := FOnOperation; + FRenderer.BufferPath := FBufferPath; FRenderer.Render; end; @@ -789,5 +1000,92 @@ procedure TRenderer.Stop; FRenderer.Stop; end; +procedure TRenderer.Hibernate(fileName: string); +begin + FRenderer.Hibernate(fileName); +end; + +function TRenderer.GetTransparentImage: TPngObject; +begin + Result := FRenderer.GetTransparentImage; +end; + +function TimeToString(t: TDateTime): string; +var + n: integer; +begin + n := Trunc(t); + Result := ''; + if n > 0 then begin + Result := Result + Format(' %d ' + TextByKey('common-days'), [n]); + //if n <> 1 then Result := Result + 's'; + end; + t := t * 24; + n := Trunc(t) mod 24; + if n > 0 then begin + Result := Result + Format(' %d ' + TextByKey('common-hours'), [n]); + //if n <> 1 then Result := Result + 's'; + end; + t := t * 60; + n := Trunc(t) mod 60; + if n > 0 then begin + Result := Result + Format(' %d ' + TextByKey('common-minutes'), [n]); + //if n <> 1 then Result := Result + 's'; + end; + t := t * 60; + t := t - (Trunc(t) div 60) * 60; + Result := Result + Format(' %.2f ' + TextByKey('common-seconds'), [t]); +end; +procedure TBaseRenderer.ShowBigStats; +var + Stats: TBucketStats; + TotalSamples: int64; + + Rbits, Gbits, Bbits, Abits: double; +begin + if not assigned(strOutput) then exit; + + strOutput.Add(''); + if NrSlices = 1 then + strOutput.Add(TextByKey('common-statistics-title-oneslice')) + else + strOutput.Add(TextByKey('common-statistics-title-multipleslices')); // not really useful :-\ + + TotalSamples := int64(FNumBatches) * SUB_BATCH_SIZE; // * fcp.nbatches ? + if TotalSamples <= 0 then begin + //strOutput.Add(' Nothing to talk about!'); // normally shouldn't happen + exit; + end; + strOutput.Add(Format(' ' + TextByKey('common-statistics-maxpossiblebits'), [8 + log2(TotalSamples)])); + FImageMaker.GetBucketStats(Stats); + with Stats do begin + if MaxR > 0 then Rbits := log2(MaxR) else Rbits := 0; + if MaxG > 0 then Gbits := log2(MaxG) else Gbits := 0; + if MaxB > 0 then Bbits := log2(MaxB) else Bbits := 0; + if MaxA > 0 then Abits := log2(MaxA) else Abits := 0; + strOutput.Add(Format(' ' + TextByKey('common-statistics-maxred'), [Rbits])); + strOutput.Add(Format(' ' + TextByKey('common-statistics-maxgreen'), [Gbits])); + strOutput.Add(Format(' ' + TextByKey('common-statistics-maxblue'), [Bbits])); + strOutput.Add(Format(' ' + TextByKey('common-statistics-maxcounter'), [Abits])); + strOutput.Add(Format(' ' + TextByKey('common-statistics-pointhitratio'), [100.0*(TotalA/TotalSamples)])); + if RenderTime > 0 then // hmm + strOutput.Add(Format(' ' + TextByKey('common-statistics-averagespeed'), [TotalSamples / (RenderTime * 24 * 60 * 60)])); + strOutput.Add(' ' + TextByKey('common-statistics-purerenderingtime') + TimeToString(RenderTime)); + end; +end; + +procedure TBaseRenderer.ShowSmallStats; +var + TotalSamples: int64; +begin + if not assigned(strOutput) then exit; + + TotalSamples := int64(FNumBatches) * SUB_BATCH_SIZE; // * fcp.nbatches ? + if RenderTime > 0 then // hmm + strOutput.Add(Format(' ' + TextByKey('common-statistics-averagespeed'), [TotalSamples / (RenderTime * 24 * 60 * 60)])); + strOutput.Add(' ' + TextByKey('common-statistics-purerenderingtime') + TimeToString(RenderTime)); +end; + + end. diff --git a/Project/Delphi2005/res/ARROW_BLACK.cur b/Source/Resources/ARROW_BLACK.cur similarity index 100% rename from Project/Delphi2005/res/ARROW_BLACK.cur rename to Source/Resources/ARROW_BLACK.cur diff --git a/Project/Delphi2005/res/ARROW_WHITE.cur b/Source/Resources/ARROW_WHITE.cur similarity index 100% rename from Project/Delphi2005/res/ARROW_WHITE.cur rename to Source/Resources/ARROW_WHITE.cur diff --git a/Project/Delphi2005/res/apophysis7x.aps b/Source/Resources/Apophysis7X_Icon.ico similarity index 51% rename from Project/Delphi2005/res/apophysis7x.aps rename to Source/Resources/Apophysis7X_Icon.ico index 31d7382..ce208ec 100644 Binary files a/Project/Delphi2005/res/apophysis7x.aps and b/Source/Resources/Apophysis7X_Icon.ico differ diff --git a/Project/Delphi2005/res/MAINICON.ico b/Source/Resources/MAINICON.ico similarity index 100% rename from Project/Delphi2005/res/MAINICON.ico rename to Source/Resources/MAINICON.ico diff --git a/Project/Delphi2005/res/MOVE_BLACK.cur b/Source/Resources/MOVE_BLACK.cur similarity index 100% rename from Project/Delphi2005/res/MOVE_BLACK.cur rename to Source/Resources/MOVE_BLACK.cur diff --git a/Project/Delphi2005/res/MOVE_WB.cur b/Source/Resources/MOVE_WB.cur similarity index 100% rename from Project/Delphi2005/res/MOVE_WB.cur rename to Source/Resources/MOVE_WB.cur diff --git a/Project/Delphi2005/res/MOVE_WHITE.cur b/Source/Resources/MOVE_WHITE.cur similarity index 100% rename from Project/Delphi2005/res/MOVE_WHITE.cur rename to Source/Resources/MOVE_WHITE.cur diff --git a/Project/Delphi2005/res/ROTATE_BLACK.cur b/Source/Resources/ROTATE_BLACK.cur similarity index 100% rename from Project/Delphi2005/res/ROTATE_BLACK.cur rename to Source/Resources/ROTATE_BLACK.cur diff --git a/Project/Delphi2005/res/ROTATE_WB.cur b/Source/Resources/ROTATE_WB.cur similarity index 100% rename from Project/Delphi2005/res/ROTATE_WB.cur rename to Source/Resources/ROTATE_WB.cur diff --git a/Project/Delphi2005/res/ROTATE_WHITE.cur b/Source/Resources/ROTATE_WHITE.cur similarity index 100% rename from Project/Delphi2005/res/ROTATE_WHITE.cur rename to Source/Resources/ROTATE_WHITE.cur diff --git a/Project/Delphi2005/res/SCALE_BLACK.cur b/Source/Resources/SCALE_BLACK.cur similarity index 100% rename from Project/Delphi2005/res/SCALE_BLACK.cur rename to Source/Resources/SCALE_BLACK.cur diff --git a/Project/Delphi2005/res/SCALE_WB.cur b/Source/Resources/SCALE_WB.cur similarity index 100% rename from Project/Delphi2005/res/SCALE_WB.cur rename to Source/Resources/SCALE_WB.cur diff --git a/Project/Delphi2005/res/SCALE_WHITE.cur b/Source/Resources/SCALE_WHITE.cur similarity index 100% rename from Project/Delphi2005/res/SCALE_WHITE.cur rename to Source/Resources/SCALE_WHITE.cur diff --git a/Project/Delphi2005/res/SplashScreen.bmp b/Source/Resources/SplashScreen.bmp similarity index 100% rename from Project/Delphi2005/res/SplashScreen.bmp rename to Source/Resources/SplashScreen.bmp diff --git a/Project/Delphi2005/res/THUMB_PLACEHOLDER.bmp b/Source/Resources/THUMB_PLACEHOLDER.bmp similarity index 100% rename from Project/Delphi2005/res/THUMB_PLACEHOLDER.bmp rename to Source/Resources/THUMB_PLACEHOLDER.bmp diff --git a/Project/Delphi2005/res/Unicode.res b/Source/Resources/Unicode.res similarity index 100% rename from Project/Delphi2005/res/Unicode.res rename to Source/Resources/Unicode.res diff --git a/Project/Delphi2005/res/apophysis7x.rc b/Source/Resources/apophysis7x.rc similarity index 100% rename from Project/Delphi2005/res/apophysis7x.rc rename to Source/Resources/apophysis7x.rc diff --git a/Project/Delphi2005/apophysis7X.res b/Source/Resources/apophysis7x.res similarity index 55% rename from Project/Delphi2005/apophysis7X.res rename to Source/Resources/apophysis7x.res index 2fe42a0..a101432 100644 Binary files a/Project/Delphi2005/apophysis7X.res and b/Source/Resources/apophysis7x.res differ diff --git a/Project/Delphi2005/res/resource.h b/Source/Resources/resource.h similarity index 100% rename from Project/Delphi2005/res/resource.h rename to Source/Resources/resource.h diff --git a/Source/System/CurvesControl.dfm b/Source/System/CurvesControl.dfm new file mode 100644 index 0000000..39378a2 --- /dev/null +++ b/Source/System/CurvesControl.dfm @@ -0,0 +1,23 @@ +object CurvesControl: TCurvesControl + Left = 0 + Top = 0 + Width = 542 + Height = 440 + DoubleBuffered = True + Color = clBlack + ParentBackground = False + ParentColor = False + ParentDoubleBuffered = False + TabOrder = 0 + object Host: TPanel + Left = 0 + Top = 0 + Width = 542 + Height = 440 + Align = alClient + BevelOuter = bvNone + Color = clBlack + ParentBackground = False + TabOrder = 0 + end +end diff --git a/Source/System/CurvesControl.pas b/Source/System/CurvesControl.pas new file mode 100644 index 0000000..9947a44 --- /dev/null +++ b/Source/System/CurvesControl.pas @@ -0,0 +1,384 @@ +unit CurvesControl; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Math, ControlPoint, + Graphics, Controls, Forms, Bezier, CustomDrawControl, Vcl.ExtCtrls; + +const + point_size: double = 8; + accurancy: double = 3; + channel_count: integer = 4; + padding = 3; + +const + MAX_CHANNEL = 3; + +type + TCurvesChannel = (ccAll = 0, ccRed = 1, ccGreen = 2, ccBlue = 3); + TCurvesControl = class(TFrame) + Host: TPanel; + private + FRect: BezierRect; + + FPoints: array [0..3] of BezierPoints; + FWeights: array [0..3] of BezierWeights; + + FDragging: boolean; + FDragIndex: integer; + + FActiveChannel : TCurvesChannel; + FChannelIndex : integer; + + FFrame : TCustomDrawControl; + FCP: TControlPoint; + + p: array [0..MAX_CHANNEL] of BezierPoints; + w: array [0..MAX_CHANNEL] of BezierWeights; + wsum: array [0..MAX_CHANNEL] of double; + + procedure SetChannel(value: TCurvesChannel); + procedure SetWeightLeft(value: double); + procedure SetWeightRight(value: double); + + function GetChannel: TCurvesChannel; + function GetWeightLeft: double; + function GetWeightRight: double; + + procedure FrameMouseLeave(Sender: TObject); + procedure FrameMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); + procedure FrameMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); + procedure FrameMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); + procedure FrameResize(Sender: TObject); + procedure FramePaint(Sender: TObject); + procedure FrameCreate; + + procedure PaintCurve(Bitmap: TBitmap; c: integer; p: BezierPoints; w: BezierWeights; widgets: boolean); + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + property WeightLeft : double read GetWeightLeft write SetWeightLeft; + property WeightRight : double read GetWeightRight write SetWeightRight; + property ActiveChannel : TCurvesChannel read GetChannel write SetChannel; + + procedure SetCp(cp: TControlPoint); + procedure UpdateFlame; + end; + +implementation + +{$R *.DFM} + +uses Main, Editor, Mutate, Adjust; + +constructor TCurvesControl.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + + FFrame := TCustomDrawControl.Create(self); + FFrame.TabStop := True; + FFrame.TabOrder := 0; + FFrame.Parent := Host; + FFrame.Align := alClient; + FFrame.Visible := True; + + FFrame.OnPaint := FramePaint; + FFrame.OnMouseDown := FrameMouseDown; + FFrame.OnMouseMove := FrameMouseMove; + FFrame.OnMouseUp := FrameMouseUp; + FFrame.OnMouseLeave := FrameMouseLeave; + + FCP := TControlPoint.Create; + + FrameCreate; +end; +destructor TCurvesControl.Destroy; +begin + FCP.Destroy; + inherited Destroy; +end; + +procedure TCurvesControl.SetCp(cp: TControlPoint); +var i, j: integer; +begin + FCP.Copy(cp, true); + for i := 0 to 3 do + for j := 0 to 3 do begin + FWeights[i,j] := FCP.curveWeights[i,j]; + FPoints[i,j].x := FCP.curvePoints[i,j].x; + FPoints[i,j].y := FCP.curvePoints[i,j].y; + end; + Invalidate; + FFrame.Invalidate; +end; +procedure TCurvesControl.UpdateFlame; +begin + MainForm.StopThread; + MainForm.UpdateUndo; + MainCp.Copy(FCP, true); + + if EditForm.Visible then EditForm.UpdateDisplay; + if MutateForm.Visible then MutateForm.UpdateDisplay; + if AdjustForm.Visible then AdjustForm.UpdateDisplay(true); + + MainForm.RedrawTimer.enabled := true; +end; + +procedure TCurvesControl.FrameMouseLeave(Sender: TObject); +begin + FrameMouseUp(nil, mbLeft, [], 0, 0); +end; +procedure TCurvesControl.FrameMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +var + ps_half: double; + i, n: integer; + p: BezierPoints; +begin + BezierCopy(FPoints[FChannelIndex], p); + BezierSetRect(p, true, FRect); + + FDragIndex := -1; + FDragging := false; + + n := Length(p); + for i := 1 to n - 2 do if + (X >= p[i].x - point_size) and (X <= p[i].x + point_size) and + (Y >= p[i].y - point_size) and (Y <= p[i].y + point_size) then + begin + FDragging := true; + FDragIndex := i; + Break; + end; +end; +procedure TCurvesControl.FrameMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); +var + m: BezierPoints; + tmp: BezierPoint; + i: Integer; + j: Integer; +begin + + if (y < 0) then Exit; + if (x < 0) then Exit; + + m[0].x := x; m[0].y := y; + BezierUnsetRect(m, true, FRect); + + if FDragging then + begin + FPoints[FChannelIndex][FDragIndex] := m[0]; + if (FPoints[FChannelIndex][FDragIndex].x <= 0) + then FPoints[FChannelIndex][FDragIndex].x := 0; + if (FPoints[FChannelIndex][FDragIndex].y <= 0) + then FPoints[FChannelIndex][FDragIndex].y := 0; + if (FPoints[FChannelIndex][FDragIndex].x >= 1) + then FPoints[FChannelIndex][FDragIndex].x := 1; + if (FPoints[FChannelIndex][FDragIndex].y >= 1) + then FPoints[FChannelIndex][FDragIndex].y := 1; + + if (FPoints[FChannelIndex][1].x > FPoints[FChannelIndex][2].x) then + begin + tmp := FPoints[FChannelIndex][1]; + FPoints[FChannelIndex][1] := FPoints[FChannelIndex][2]; + FPoints[FChannelIndex][2] := tmp; + if (FDragIndex = 1) then FDragIndex := 2 + else FDragIndex := 1; + end; + + for i := 0 to 3 do + for j := 0 to 3 do begin + FCP.curveWeights[i,j] := FWeights[i,j]; + FCP.curvePoints[i,j].x := FPoints[i,j].x; + FCP.curvePoints[i,j].y := FPoints[i,j].y; + end; + + + FFrame.Refresh; + end; +end; +procedure TCurvesControl.FrameMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); +begin + FDragIndex := -1; + FDragging := false; + + if (sender <> nil) then UpdateFlame; +end; + +procedure TCurvesControl.FrameCreate; +var i: integer; +begin + for i := 0 to channel_count - 1 do + begin + FPoints[i][0].x := 0.00; FPoints[i][0].y := 0.00; FWeights[i][0] := 1; + FPoints[i][1].x := 0.00; FPoints[i][1].y := 0.00; FWeights[i][1] := 1; + FPoints[i][2].x := 1.00; FPoints[i][2].y := 1.00; FWeights[i][2] := 1; + FPoints[i][3].x := 1.00; FPoints[i][3].y := 1.00; FWeights[i][3] := 1; + end; + + FDragIndex := -1; + FDragging := false; +end; +procedure TCurvesControl.FrameResize(Sender: TObject); +begin + FRect.x0 := 0; FRect.y0 := 0; + FRect.x1 := self.Width - 1; + FRect.y1 := self.Height - 1; +end; +procedure TCurvesControl.FramePaint(Sender: TObject); +var + clientRect: TRect; + i, j, x, y, sx, sy: integer; + bitmap: TBitMap; +begin + if (FFrame.Width <= 0) or (FFrame.Height <= 0) then Exit; + FrameResize(Sender); + + Bitmap := TBitmap.Create; + Bitmap.Width := FFrame.Width; + Bitmap.Height := FFrame.Height; + + sx := Bitmap.Width; + sy := Bitmap.Height; + + try + with Bitmap.Canvas do + begin + Brush.Color := $000000; + FillRect(Rect(0, 0, sx, sy)); + + Pen.Color := $555555; + Pen.Style := psSolid; + Pen.Width := 1; + + for x := 1 to 7 do begin + MoveTo(Round(0.125 * x * FRect.x1), Round(FRect.y0)); + LineTo(Round(0.125 * x * FRect.x1), Round(FRect.y1)); + end; + for y := 1 to 3 do begin + MoveTo(Round(FRect.x0), Round(0.25 * y * FRect.y1)); + LineTo(Round(FRect.x1), Round(0.25 * y * FRect.y1)); + end; + + for i := 0 to channel_count - 1 do begin + for j := 0 to 3 do + wsum[i] := wsum[i] + FWeights[i][j]; + for j := 0 to 3 do + w[i][j] := FWeights[i][j] / wsum[i]; + + BezierCopy(FPoints[i], p[i]); + BezierSetRect(p[i], true, FRect); + + if i <> FChannelIndex then PaintCurve(Bitmap, i, p[i], w[i], false); + end; + PaintCurve(Bitmap, FChannelIndex, p[FChannelIndex], w[FChannelIndex], true); + + FFrame.Canvas.Draw(0, 0, Bitmap); + end; + finally + Bitmap.Free; + end; +end; + +procedure TCurvesControl.PaintCurve(Bitmap: TBitmap; c: integer; p: BezierPoints; w: BezierWeights; widgets: boolean); +var + pos0, pos1: BezierPoint; + t, step: Double; + r, g, b: array [0 .. MAX_CHANNEL] of integer; + rgbv: integer; +begin + with Bitmap.Canvas do + begin + if c <> FChannelIndex then begin + r[0] := $aa; r[1] := $aa; r[2] := $40; r[3] := $40; + g[0] := $aa; g[1] := $40; g[2] := $aa; g[3] := $40; + b[0] := $aa; b[1] := $40; b[2] := $40; b[3] := $aa; + end else begin + r[0] := $ff; r[1] := $ff; r[2] := $80; r[3] := $80; + g[0] := $ff; g[1] := $80; g[2] := $ff; g[3] := $80; + b[0] := $ff; b[1] := $80; b[2] := $80; b[3] := $ff; + end; + + rgbv := RGB(r[c], g[c], b[c]); + + t := 0; + step := 0.001; + + BezierSolve(0, p, w, pos1); + pos0.x := 0; pos0.y := pos1.y; + + if widgets then begin + Pen.Color := $808080; Pen.Width := 1; + MoveTo(Round(p[1].x), Round(p[1].y)); + LineTo(Round(p[2].x), Round(p[2].y)); + MoveTo(Round(FRect.x0), Round(FRect.y1)); + LineTo(Round(p[1].x), Round(p[1].y)); + MoveTo(Round(FRect.x1), Round(FRect.y0)); + LineTo(Round(p[2].x), Round(p[2].y)); + end; + + while t < 1 do begin + BezierSolve(t, p, w, pos1); + Pen.Color := rgbv; + Pen.Width := 1; + MoveTo(Round(pos0.x), Round(pos0.y)); + LineTo(Round(pos1.x), Round(pos1.y)); + t := t + step; + pos0 := pos1; + end; + + MoveTo(Round(pos0.x), Round(pos0.y)); + LineTo(Round(FRect.x1), Round(pos0.y)); + + if widgets then begin + Brush.Color := rgbv; + Ellipse( + Round(p[1].x - point_size / 2.0), + Round(p[1].y - point_size / 2.0), + Round(p[1].x + point_size / 2.0), + Round(p[1].y + point_size / 2.0) + ); + Ellipse( + Round(p[2].x - point_size / 2.0), + Round(p[2].y - point_size / 2.0), + Round(p[2].x + point_size / 2.0), + Round(p[2].y + point_size / 2.0) + ); + end; + end; +end; + +procedure TCurvesControl.SetChannel(value: TCurvesChannel); +begin + FActiveChannel := value; + FChannelIndex := Integer(value); + FFrame.Refresh; +end; +procedure TCurvesControl.SetWeightLeft(value: double); +begin + FWeights[FChannelIndex][1] := value; + FCP.curveWeights[FChannelIndex][1] := value; + FFrame.Refresh; +end; +procedure TCurvesControl.SetWeightRight(value: double); +begin + FWeights[FChannelIndex][2] := value; + FCP.curveWeights[FChannelIndex][2] := value; + FFrame.Refresh; +end; + +function TCurvesControl.GetChannel: TCurvesChannel; +begin + Result := FActiveChannel; +end; +function TCurvesControl.GetWeightLeft: double; +begin + Result := FWeights[FChannelIndex][1]; +end; +function TCurvesControl.GetWeightRight: double; +begin + Result := FWeights[FChannelIndex][2]; +end; + +end. diff --git a/Source/System/FastMM4.pas b/Source/System/FastMM4.pas index d87a098..e817105 100644 --- a/Source/System/FastMM4.pas +++ b/Source/System/FastMM4.pas @@ -1,11 +1,12 @@ (* -Fast Memory Manager 4.84 +Fast Memory Manager 4.99 Description: - A fast replacement memory manager for Borland Delphi Win32 applications that - scales well under multi-threaded usage, is not prone to memory fragmentation, - and supports shared memory without the use of external .DLL files. + A fast replacement memory manager for Embarcadero Delphi Win32 applications + that scales well under multi-threaded usage, is not prone to memory + fragmentation, and supports shared memory without the use of external .DLL + files. Homepage: http://fastmm.sourceforge.net @@ -29,7 +30,7 @@ - Optionally reports memory leaks on program shutdown. (This check can be set to be performed only if Delphi is currently running on the machine, so end users won't be bothered by the error message.) - - Supports Delphi 4 (or later), C++ Builder 5 (or later), Kylix 3. + - Supports Delphi 4 (or later), C++ Builder 4 (or later), Kylix 3. Usage: Delphi: @@ -83,7 +84,7 @@ Support: If you have trouble using FastMM, you are welcome to drop me an e-mail at the address above, or you may post your questions in the BASM newsgroup on the - Borland news server (which is where I hang out quite frequently). + Embarcadero news server (which is where I hang out quite frequently). Disclaimer: FastMM has been tested extensively with both single and multithreaded @@ -178,8 +179,8 @@ suggestions. - JRG ("The Delphi Guy") for the Spanish translation. - Justus Janssen for Delphi 4 support. - - Vadim Lopushansky and Charles Vinal for reporting the Delphi 5 compile error - in version 4.50. + - Vadim Lopushansky and Charles Vinal for reporting the Delphi 5 compiler + error in version 4.50. - Johni Jeferson Capeletto for the Brazilian Portuguese translation. - Kurt Fitzner for reporting the BCb6 compiler error in 4.52. - Michal Niklas for reporting the Kylix compiler error in 4.54. @@ -220,7 +221,22 @@ - Marcus Mönnig for the ScanMemoryPoolForCorruptions suggestion and the suggestion to have the option to scan the memory pool before every operation when in FullDebugMode. - - Craig Peterson for the SuppressMessageBoxes suggestion. + - Francois Piette for bringing under my attention that + ScanMemoryPoolForCorruption was not thread safe. + - Michael Rabatscher for reporting some compiler warnings. + - QianYuan Wang for the Simplified Chinese translation of FastMM4Options.inc. + - Maurizio Lotauro and Christian-W. Budde for reporting some Delphi 5 + compiler errors. + - Patrick van Logchem for the DisableLoggingOfMemoryDumps option. + - Norbert Spiegel for the BCB4 support code. + - Uwe Schuster for the improved string leak detection code. + - Murray McGowan for improvements to the usage tracker. + - Michael Hieke for the SuppressFreeMemErrorsInsideException option as well + as a bugfix to GetMemoryMap. + - Richard Bradbrook for fixing the Windows 95 FullDebugMode support that was + broken in version 4.94. + - Zach Saw for the suggestion to (optionally) use SwitchToThread when + waiting for a lock on a shared resource to be released. - Everyone who have made donations. Thanks! - Any other Fastcoders or supporters that I have forgotten, and also everyone that helped with the older versions. @@ -533,7 +549,7 @@ MM sharing has to be enabled otherwise it has no effect (refer to the documentation for the "ShareMM" and "AttemptToUseSharedMM" options). Version 4.62 (22 February 2006): - - Fixed a possible read access violation in the MoveX16L4 routine when the + - Fixed a possible read access violation in the MoveX16LP routine when the UseCustomVariableSizeMoveRoutines option is enabled. (Thanks to Jud Cole for some great detective work in finding this bug.) - Improved the downsizing behaviour of medium blocks to better correlate with @@ -683,6 +699,133 @@ - Added the leak reporting code for C++ Builder, as well as various other C++ Builder bits written by JiYuan Xie. (Thank you!) - Added the new Usage Tracker written by Hanspeter Widmer. (Thank you!) + Version 4.86 (31 July 2008): + - Tweaked the string detection algorithm somewhat to be less strict, and + allow non-class leaks to be more often categorized as strings. + - Fixed a compilation error under Delphi 5. + - Made LogAllocatedBlocksToFile and ScanMemoryPoolForCorruptions thread + safe. (Thanks to Francois Piette.) + Version 4.88 (13 August 2008): + - Fixed compiler warnings in NoOpRegisterExpectedMemoryLeak and + NoOpUnRegisterExpectedMemoryLeak. (Thanks to Michael Rabatscher.) + - Added the Simplified Chinese translation of FastMM4Options.inc by + QianYuan Wang. (Thank you!) + - Included the updated C++ Builder files with support for BCB6 without + update 4 applied. (Submitted by JiYuan Xie. Thanks!) + - Fixed a compilation error under Delphi 5. + - Made LogAllocatedBlocksToFile and ScanMemoryPoolForCorruptions thread + safe - for real this time. (Thanks to Francois Piette.) + Version 4.90 (9 September 2008): + - Added logging of the thread ID when capturing and displaying stack + traces. (Suggested by Allen Bauer and Mark Edington.) + - Fixed a Delphi 5 compiler error under FullDebugMode. (Thanks to Maurizio + Lotauro and Christian-W. Budde.) + - Changed a default setting in FastMM4Options.inc: RawStackTraces is now + off by default due to the high number of support requests I receive with + regards to the false postives it may cause. I recommend compiling debug + builds of applications with the "Stack Frames" option enabled. + - Fixed a compilation error under Kylix. (Thanks to Werner Bochtler.) + - Official support for Delphi 2009. + Version 4.92 (25 November 2008): + - Added the DisableLoggingOfMemoryDumps option under FullDebugMode. When + this option is set, memory dumps will not be logged for memory leaks or + errors. (Thanks to Patrick van Logchem.) + - Exposed the class and string type detection code in the interface section + for use in application code (if required). (Requested by Patrick van + Logchem.) + - Fixed a bug in SetMMLogFileName that could cause the log file name to be + set incorrectly. + - Added BCB4 support. (Thanks to Norbert Spiegel.) + - Included the updated Czech translation by Rene Mihula. + - When FastMM raises an error due to a freed block being modified, it now + logs detail about which bytes in the block were modified. + Version 4.94 (28 August 2009): + - Added the DoNotInstallIfDLLMissing option that prevents FastMM from + installing itself if the FastMM_FullDebugMode.dll library is not + available. (Only applicable when FullDebugMode and LoadDebugDLLDynamically + are both enabled.) This is useful when the same executable will be used for + both debugging and deployment - when the debug support DLL is available + FastMM will be installed in FullDebugMode, and otherwise the default memory + manager will be used. + - Added the FullDebugModeWhenDLLAvailable option that combines the + FullDebugMode, LoadDebugDLLDynamically and DoNotInstallIfDLLMissing options. + - Re-enabled RawStackTraces by default. The frame based stack traces (even + when compiling with stack frames enabled) are generally too incomplete. + - Improved the speed of large block operations under FullDebugMode: Since + large blocks are never reused, there is no point in clearing them before + and after use (so it does not do that anymore). + - If an error occurs in FullDebugMode and FastMM is unable to append to the + log file, it will attempt to write to a log file of the same name in the + "My Documents" folder. This feature is helpful when the executable resides + in a read-only location and the default log file, which is derived from the + executable name, would thus not be writeable. + - Added support for controlling the error log file location through an + environment variable. If the 'FastMMLogFilePath' environment variable is + set then any generated error logs will be written to the specified folder + instead of the default location (which is the same folder as the + application). + - Improved the call instruction detection code in the FastMM_FullDebugMode + library. (Thanks to the JCL team.) + - Improved the string leak detection and reporting code. (Thanks to Uwe + Schuster.) + - New FullDebugMode feature: Whenever FreeMem or ReallocMem is called, FastMM + will check that the block was actually allocated through the same FastMM + instance. This is useful for tracking down memory manager sharing issues. + - Compatible with Delphi 2010. + Version 4.96 (31 August 2010): + - Reduced the minimum block size to 4 bytes from the previous value of 12 + bytes (only applicable to 8 byte alignment). This reduces memory usage if + the application allocates many blocks <= 4 bytes in size. + - Added colour-coded change indication to the FastMM usage tracker, making + it easier to spot changes in the memory usage grid. (Thanks to Murray + McGowan.) + - Added the SuppressFreeMemErrorsInsideException FullDebugMode option: If + FastMM encounters a problem with a memory block inside the FullDebugMode + FreeMem handler then an "invalid pointer operation" exception will usually + be raised. If the FreeMem occurs while another exception is being handled + (perhaps in the try.. finally code) then the original exception will be + lost. With this option set FastMM will ignore errors inside FreeMem when an + exception is being handled, thus allowing the original exception to + propagate. This option is on by default. (Thanks to Michael Hieke.) + - Fixed Windows 95 FullDebugMode support that was broken in 4.94. (Thanks to + Richard Bradbrook.) + - Fixed a bug affecting GetMemoryMap performance and accuracy of measurements + above 2GB if a large address space is not enabled for the project. (Thanks + to Michael Hieke.) + - Added the FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak boolean flag. + When set, all allocations are automatically registered as expected memory + leaks. Only available in FullDebugMode. (Thanks to Brian Cook.) + - Compatible with Delphi XE. + Version 4.97 (30 September 2010): + - Fixed a crash bug (that crept in in 4.96) that may manifest itself when + resizing a block to 4 bytes or less. + - Added the UseSwitchToThread option. Set this option to call SwitchToThread + instead of sitting in a "busy waiting" loop when a thread contention + occurs. This is used in conjunction with the NeverSleepOnThreadContention + option, and has no effect unless NeverSleepOnThreadContention is also + defined. This option may improve performance with many CPU cores and/or + threads of different priorities. Note that the SwitchToThread API call is + only available on Windows 2000 and later. (Thanks to Zach Saw.) + Version 4.98 (23 September 2011): + - Added the FullDebugModeCallBacks define which adds support for memory + manager event callbacks. This allows the application to be notified of + memory allocations, frees and reallocations as they occur. (Thanks to + Jeroen Pluimers.) + - Added security options ClearMemoryBeforeReturningToOS and + AlwaysClearFreedMemory to force the clearing of memory blocks after being + freed. This could possibly provide some protection against information + theft, but at a significant performance penalty. (Thanks to Andrey + Sozonov.) + - Shifted the code in the initialization section to a procedure + RunInitializationCode. This allows the startup code to be called before + InitUnits, which is required by some software protection tools. + - Added support for Delphi XE2 (Windows 32-bit and Windows 64-bit platforms + only). + Version 4.99 (6 November 2011): + - Fixed crashes in the 64-bit BASM codepath when more than 4GB of memory is + allocated. + - Fixed bad record alignment under 64-bit that affected performance. + - Fixed compilation errors with some older compilers. *) @@ -691,13 +834,83 @@ interface {$Include FastMM4Options.inc} -{$undef EnableMemoryLeakReporting} {$RANGECHECKS OFF} {$BOOLEVAL OFF} {$OVERFLOWCHECKS OFF} {$OPTIMIZATION ON} {$TYPEDADDRESS OFF} +{$LONGSTRINGS ON} + +{Compiler version defines} +{$ifndef BCB} + {$ifdef ver120} + {$define Delphi4or5} + {$endif} + {$ifdef ver130} + {$define Delphi4or5} + {$endif} + {$ifdef ver140} + {$define Delphi6} + {$endif} + {$ifdef ver150} + {$define Delphi7} + {$endif} + {$ifdef ver170} + {$define Delphi2005} + {$endif} +{$else} + {for BCB4, use the Delphi 5 codepath} + {$ifdef ver120} + {$define Delphi4or5} + {$define BCB4} + {$endif} + {for BCB5, use the Delphi 5 codepath} + {$ifdef ver130} + {$define Delphi4or5} + {$endif} +{$endif} +{$ifdef ver180} + {$define BDS2006} +{$endif} +{$define 32Bit} +{$ifndef Delphi4or5} + {$if SizeOf(Pointer) = 8} + {$define 64Bit} + {$undef 32Bit} + {$ifend} + {$if CompilerVersion >= 23} + {$define XE2AndUp} + {$ifend} + {$define BCB6OrDelphi6AndUp} + {$ifndef BCB} + {$define Delphi6AndUp} + {$endif} + {$ifndef Delphi6} + {$define BCB6OrDelphi7AndUp} + {$ifndef BCB} + {$define Delphi7AndUp} + {$endif} + {$ifndef BCB} + {$ifndef Delphi7} + {$ifndef Delphi2005} + {$define BDS2006AndUp} + {$endif} + {$endif} + {$endif} + {$endif} +{$endif} + +{$ifdef 64Bit} + {Under 64 bit memory blocks must always be 16-byte aligned} + {$define Align16Bytes} + {No need for MMX under 64-bit, since SSE2 is available} + {$undef EnableMMX} + {There is little need for raw stack traces under 64-bit, since frame based + stack traces are much more accurate than under 32-bit. (And frame based + stack tracing is much faster.)} + {$undef RawStackTraces} +{$endif} {IDE debug mode always enables FullDebugMode and dynamic loading of the FullDebugMode DLL.} {$ifdef FullDebugModeInIDE} @@ -706,6 +919,13 @@ interface {$define LoadDebugDLLDynamically} {$endif} +{Install in FullDebugMode only when the DLL is available?} +{$ifdef FullDebugModeWhenDLLAvailable} + {$define FullDebugMode} + {$define LoadDebugDLLDynamically} + {$define DoNotInstallIfDLLMissing} +{$endif} + {Some features not currently supported under Kylix} {$ifdef Linux} {$undef FullDebugMode} @@ -743,68 +963,47 @@ interface {$undef AlwaysAllocateTopDown} {$endif} -{Only the pascal version supports extended heap corruption checking.} -{$ifdef CheckHeapForCorruption} - {$undef ASMVersion} -{$endif} - -{$ifdef UseRuntimePackages} - {$define AssumeMultiThreaded} -{$endif} - -{Delphi versions} -{$ifndef BCB} - {$ifdef ver120} - {$define Delphi4or5} - {$endif} - {$ifdef ver130} - {$define Delphi4or5} - {$endif} - {$ifdef ver140} - {$define Delphi6} - {$endif} - {$ifdef ver150} - {$define Delphi7} +{Set defines for security options} +{$ifdef FullDebugMode} + {In FullDebugMode small and medium blocks are always cleared when calling + FreeMem. Large blocks are always returned to the OS immediately.} + {$ifdef ClearMemoryBeforeReturningToOS} + {$define ClearLargeBlocksBeforeReturningToOS} {$endif} - {$ifdef ver170} - {$define Delphi2005} + {$ifdef AlwaysClearFreedMemory} + {$define ClearLargeBlocksBeforeReturningToOS} {$endif} {$else} - {$ifndef PatchBCBTerminate} - {Cannot uninstall safely under BCB} - {$define NeverUninstall} - {Disable memory leak reporting} - {$undef EnableMemoryLeakReporting} - {$endif} - {for BCB5, use the Delphi 5 codepath} - {$ifdef ver130} - {$define Delphi4or5} + {If memory blocks are cleared in FreeMem then they do not need to be cleared + before returning the memory to the OS.} + {$ifdef AlwaysClearFreedMemory} + {$define ClearSmallAndMediumBlocksInFreeMem} + {$define ClearLargeBlocksBeforeReturningToOS} + {$else} + {$ifdef ClearMemoryBeforeReturningToOS} + {$define ClearMediumBlockPoolsBeforeReturningToOS} + {$define ClearLargeBlocksBeforeReturningToOS} + {$endif} {$endif} {$endif} -{$ifdef ver180} - {$define BDS2006} + +{Only the Pascal version supports extended heap corruption checking.} +{$ifdef CheckHeapForCorruption} + {$undef ASMVersion} {$endif} -{$ifndef Delphi4or5} - {$ifndef BCB} - {$define Delphi6AndUp} - {$endif} - {$ifndef Delphi6} - {$define BCB6OrDelphi7AndUp} - {$ifndef BCB} - {$define Delphi7AndUp} - {$endif} - {$ifndef BCB} - {$ifndef Delphi7} - {$ifndef Delphi2005} - {$define BDS2006AndUp} - {$endif} - {$endif} - {$endif} +{For BASM bits that are not implemented in 64-bit.} +{$ifdef 32Bit} + {$ifdef ASMVersion} + {$define Use32BitAsm} {$endif} {$endif} -{$ifdef Delphi6AndUp} +{$ifdef UseRuntimePackages} + {$define AssumeMultiThreaded} +{$endif} + +{$ifdef BCB6OrDelphi6AndUp} {$WARN SYMBOL_PLATFORM OFF} {$WARN SYMBOL_DEPRECATED OFF} {$endif} @@ -840,51 +1039,85 @@ interface {$DEBUGINFO OFF} {$endif} +{$ifdef BCB} + {$ifdef borlndmmdll} + {$OBJEXPORTALL OFF} + {$endif} + {$ifndef PatchBCBTerminate} + {Cannot uninstall safely under BCB} + {$define NeverUninstall} + {Disable memory leak reporting} + {$undef EnableMemoryLeakReporting} + {$endif} +{$endif} + {-------------------------Public constants-----------------------------} const {The current version of FastMM} - FastMMVersion = '4.84'; + FastMMVersion = '4.99'; {The number of small block types} {$ifdef Align16Bytes} NumSmallBlockTypes = 46; {$else} - NumSmallBlockTypes = 55; + NumSmallBlockTypes = 56; {$endif} {----------------------------Public types------------------------------} type - TSmallBlockTypeState = packed record + + {Make sure all the required types are available} +{$ifdef BCB6OrDelphi6AndUp} + {$if CompilerVersion < 20} + PByte = PAnsiChar; + {$ifend} + {$if CompilerVersion < 23} + NativeInt = Integer; + NativeUInt = Cardinal; + PNativeUInt = ^Cardinal; + IntPtr = Integer; + UIntPtr = Cardinal; + {$ifend} +{$else} + PByte = PAnsiChar; + NativeInt = Integer; + NativeUInt = Cardinal; + PNativeUInt = ^Cardinal; + IntPtr = Integer; + UIntPtr = Cardinal; +{$endif} + + TSmallBlockTypeState = record {The internal size of the block type} InternalBlockSize: Cardinal; {Useable block size: The number of non-reserved bytes inside the block.} UseableBlockSize: Cardinal; {The number of allocated blocks} - AllocatedBlockCount: Cardinal; + AllocatedBlockCount: NativeUInt; {The total address space reserved for this block type (both allocated and free blocks)} - ReservedAddressSpace: Cardinal; + ReservedAddressSpace: NativeUInt; end; TSmallBlockTypeStates = array[0..NumSmallBlockTypes - 1] of TSmallBlockTypeState; - TMemoryManagerState = packed record + TMemoryManagerState = record {Small block type states} SmallBlockTypeStates: TSmallBlockTypeStates; {Medium block stats} AllocatedMediumBlockCount: Cardinal; - TotalAllocatedMediumBlockSize: Cardinal; - ReservedMediumBlockAddressSpace: Cardinal; + TotalAllocatedMediumBlockSize: NativeUInt; + ReservedMediumBlockAddressSpace: NativeUInt; {Large block stats} AllocatedLargeBlockCount: Cardinal; - TotalAllocatedLargeBlockSize: Cardinal; - ReservedLargeBlockAddressSpace: Cardinal; + TotalAllocatedLargeBlockSize: NativeUInt; + ReservedLargeBlockAddressSpace: NativeUInt; end; - TMemoryManagerUsageSummary = packed record + TMemoryManagerUsageSummary = record {The total number of bytes allocated by the application.} - AllocatedBytes: Cardinal; + AllocatedBytes: NativeUInt; {The total number of address space bytes used by control structures, or lost due to fragmentation and other overhead.} - OverheadBytes: Cardinal; + OverheadBytes: NativeUInt; {The efficiency of the memory manager expressed as a percentage. This is 100 * AllocatedBytes / (AllocatedBytes + OverheadBytes).} EfficiencyPercentage: Double; @@ -897,18 +1130,22 @@ interface {$ifdef EnableMemoryLeakReporting} {List of registered leaks} - TRegisteredMemoryLeak = packed record + TRegisteredMemoryLeak = record LeakAddress: Pointer; LeakedClass: TClass; {$ifdef CheckCppObjectTypeEnabled} LeakedCppTypeIdPtr: Pointer; {$endif} - LeakSize: Integer; + LeakSize: NativeInt; LeakCount: Integer; end; TRegisteredMemoryLeaks = array of TRegisteredMemoryLeak; {$endif} + {Used by the DetectStringData routine to detect whether a leaked block + contains string data.} + TStringDataType = (stUnknown, stAnsiString, stUnicodeString); + {--------------------------Public variables----------------------------} var {If this variable is set to true and FullDebugMode is enabled, then the @@ -917,16 +1154,20 @@ interface the already significant FullDebugMode overhead, so enable this option only when absolutely necessary.} FullDebugModeScanMemoryPoolBeforeEveryOperation: Boolean = False; + FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak: Boolean = False; {$ifdef ManualLeakReportingControl} {Variable is declared in system.pas in newer Delphi versions.} {$ifndef BDS2006AndUp} ReportMemoryLeaksOnShutdown: Boolean; {$endif} {$endif} - {If set to true, disables the display of all messageboxes} + {If set to True, disables the display of all messageboxes} SuppressMessageBoxes: Boolean; {-------------------------Public procedures----------------------------} +{Executes the code normally run in the initialization section. Running it + earlier may be required with e.g. some software protection tools.} +procedure RunInitializationCode; {Installation procedures must be exposed for the BCB helper unit FastMM4BCB.cpp} {$ifdef BCB} procedure InitializeMemoryManager; @@ -970,7 +1211,7 @@ procedure FinalizeMemoryManager; {For completion of "RequireDebuggerPresenceForLeakReporting" checking in "FinalizeMemoryManager"} var - pCppDebugHook: PInteger = nil; + pCppDebugHook: ^Integer = nil; //PInteger not defined in BCB5 {$ifdef CheckCppObjectTypeEnabled} (*$HPPEMIT ''#13#10 *) @@ -999,16 +1240,16 @@ procedure FinalizeMemoryManager; {$ifndef FullDebugMode} {The standard memory manager functions} -function FastGetMem(ASize: Integer): Pointer; +function FastGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; function FastFreeMem(APointer: Pointer): Integer; -function FastReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; -function FastAllocMem(ASize: Cardinal): Pointer; +function FastReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; +function FastAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer; {$else} {The FullDebugMode memory manager functions} -function DebugGetMem(ASize: Integer): Pointer; +function DebugGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; function DebugFreeMem(APointer: Pointer): Integer; -function DebugReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; -function DebugAllocMem(ASize: Cardinal): Pointer; +function DebugReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; +function DebugAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer; {Scans the memory pool for any corruptions. If a corruption is encountered an "Out of Memory" exception is raised.} procedure ScanMemoryPoolForCorruptions; @@ -1056,50 +1297,179 @@ procedure GetMemoryMap(var AMemoryMap: TMemoryMap); blocks is limited, so failure is possible if the list is full.} function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overload; function RegisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): Boolean; overload; -function RegisterExpectedMemoryLeak(ALeakedBlockSize: Integer; ACount: Integer = 1): Boolean; overload; +function RegisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload; {$ifdef CheckCppObjectTypeEnabled} {Registers expected memory leaks by virtual object's typeId pointer. Usage: RegisterExpectedMemoryLeak(typeid(ACppObject).tpp, Count);} -function RegisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer = 1): boolean; overload; +function RegisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): boolean; overload; {$endif} {Removes expected memory leaks. Returns true on success.} function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overload; function UnregisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer = 1): Boolean; overload; -function UnregisterExpectedMemoryLeak(ALeakedBlockSize: Integer; ACount: Integer = 1): Boolean; overload; +function UnregisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload; {$ifdef CheckCppObjectTypeEnabled} {Usage: UnregisterExpectedMemoryLeak(typeid(ACppObject).tpp, Count);} -function UnregisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer = 1): boolean; overload; +function UnregisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): boolean; overload; {$endif} {Returns a list of all expected memory leaks} function GetRegisteredMemoryLeaks: TRegisteredMemoryLeaks; {$endif} +{Returns the class for a memory block. Returns nil if it is not a valid class. + Used by the leak detection code.} +function DetectClassInstance(APointer: Pointer): TClass; +{Detects the probable string data type for a memory block. Used by the leak + classification code when a block cannot be identified as a known class + instance.} +function DetectStringData(APMemoryBlock: Pointer; + AAvailableSpaceInBlock: NativeInt): TStringDataType; + +{$ifdef FullDebugMode} +{-------------FullDebugMode constants---------------} +const + {The stack trace depth. (Must be an *uneven* number to ensure that the + Align16Bytes option works in FullDebugMode.)} + StackTraceDepth = 11; + {The number of entries in the allocation group stack} + AllocationGroupStackSize = 1000; + {The number of fake VMT entries - used to track virtual method calls on + freed objects. Do not change this value without also updating TFreedObject.GetVirtualMethodIndex} + MaxFakeVMTEntries = 200; + {The pattern used to fill unused memory} + DebugFillByte = $80; +{$ifdef 32Bit} + DebugFillPattern = $01010101 * Cardinal(DebugFillByte); + {The address that is reserved so that accesses to the address of the fill + pattern will result in an A/V. (Not used under 64-bit, since the upper half + of the address space is always reserved by the OS.)} + DebugReservedAddress = $01010000 * Cardinal(DebugFillByte); +{$else} + DebugFillPattern = $8080808080808080; +{$endif} + +{-------------------------FullDebugMode structures--------------------} +type + PStackTrace = ^TStackTrace; + TStackTrace = array[0..StackTraceDepth - 1] of NativeUInt; + + TBlockOperation = (boBlockCheck, boGetMem, boFreeMem, boReallocMem); + + {The header placed in front of blocks in FullDebugMode (just after the + standard header). Must be a multiple of 16 bytes in size otherwise the + Align16Bytes option will not work. Current size = 128 bytes under 32-bit, + and 240 bytes under 64-bit.} + PFullDebugBlockHeader = ^TFullDebugBlockHeader; + TFullDebugBlockHeader = record + {Space used by the medium block manager for previous/next block management. + If a medium block is binned then these two fields will be modified.} + Reserved1: Pointer; + Reserved2: Pointer; + {Is the block currently allocated? If it is allocated this will be the + address of the getmem routine through which it was allocated, otherwise it + will be nil.} + AllocatedByRoutine: Pointer; + {The allocation group: Can be used in the debugging process to group + related memory leaks together} + AllocationGroup: Cardinal; + {The allocation number: All new allocations are numbered sequentially. This + number may be useful in memory leak analysis. If it reaches 4G it wraps + back to 0.} + AllocationNumber: Cardinal; + {The call stack when the block was allocated} + AllocationStackTrace: TStackTrace; + {The thread that allocated the block} + AllocatedByThread: Cardinal; + {The thread that freed the block} + FreedByThread: Cardinal; + {The call stack when the block was freed} + FreeStackTrace: TStackTrace; + {The user requested size for the block. 0 if this is the first time the + block is used.} + UserSize: NativeUInt; + {The object class this block was used for the previous time it was + allocated. When a block is freed, the pointer that would normally be in the + space of the class pointer is copied here, so if it is detected that + the block was used after being freed we have an idea what class it is.} + PreviouslyUsedByClass: NativeUInt; + {The sum of all the dwords(32-bit)/qwords(64-bit) in this structure + excluding the initial two reserved fields and this field.} + HeaderCheckSum: NativeUInt; + end; + {The NativeUInt following the user area of the block is the inverse of + HeaderCheckSum. This is used to catch buffer overrun errors.} + + {The class used to catch attempts to execute a virtual method of a freed + object} + TFreedObject = class + public + procedure GetVirtualMethodIndex; + procedure VirtualMethodError; +{$ifdef CatchUseOfFreedInterfaces} + procedure InterfaceError; +{$endif} + end; + +{$ifdef FullDebugModeCallBacks} + {FullDebugMode memory manager event callbacks. Note that APHeaderFreedBlock in the TOnDebugFreeMemFinish + will not be valid for large (>260K) blocks.} + TOnDebugGetMemFinish = procedure(APHeaderNewBlock: PFullDebugBlockHeader; ASize: NativeInt); + TOnDebugFreeMemStart = procedure(APHeaderBlockToFree: PFullDebugBlockHeader); + TOnDebugFreeMemFinish = procedure(APHeaderFreedBlock: PFullDebugBlockHeader; AResult: Integer); + TOnDebugReallocMemStart = procedure(APHeaderBlockToReallocate: PFullDebugBlockHeader; ANewSize: NativeInt); + TOnDebugReallocMemFinish = procedure(APHeaderReallocatedBlock: PFullDebugBlockHeader; ANewSize: NativeInt); + +var + {Note: FastMM will not catch exceptions inside these hooks, so make sure your hook code runs without + exceptions.} + OnDebugGetMemFinish: TOnDebugGetMemFinish = nil; + OnDebugFreeMemStart: TOnDebugFreeMemStart = nil; + OnDebugFreeMemFinish: TOnDebugFreeMemFinish = nil; + OnDebugReallocMemStart: TOnDebugReallocMemStart = nil; + OnDebugReallocMemFinish: TOnDebugReallocMemFinish = nil; +{$endif} +{$endif} + implementation uses {$ifndef Linux} Windows, + {$ifdef FullDebugMode} + {$ifdef Delphi4or5} + ShlObj, + {$else} + SHFolder, + {$endif} + {$endif} {$else} Libc, {$endif} FastMM4Messages; -{Fixed size move procedures} -procedure Move12(const ASource; var ADest; ACount: Integer); forward; -procedure Move20(const ASource; var ADest; ACount: Integer); forward; -procedure Move28(const ASource; var ADest; ACount: Integer); forward; -procedure Move36(const ASource; var ADest; ACount: Integer); forward; -procedure Move44(const ASource; var ADest; ACount: Integer); forward; -procedure Move52(const ASource; var ADest; ACount: Integer); forward; -procedure Move60(const ASource; var ADest; ACount: Integer); forward; -procedure Move68(const ASource; var ADest; ACount: Integer); forward; +{Fixed size move procedures. The 64-bit versions assume 16-byte alignment.} +procedure Move4(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move12(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move20(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move28(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move36(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move44(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move52(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move60(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move68(const ASource; var ADest; ACount: NativeInt); forward; +{$ifdef 64Bit} +{These are not needed and thus unimplemented under 32-bit} +procedure Move8(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move24(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move40(const ASource; var ADest; ACount: NativeInt); forward; +procedure Move56(const ASource; var ADest; ACount: NativeInt); forward; +{$endif} {$ifdef DetectMMOperationsAfterUninstall} {Invalid handlers to catch MM operations after uninstall} function InvalidFreeMem(APointer: Pointer): Integer; forward; -function InvalidGetMem(ASize: Integer): Pointer; forward; -function InvalidReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; forward; -function InvalidAllocMem(ASize: Cardinal): Pointer; forward; +function InvalidGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; forward; +function InvalidReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; forward; +function InvalidAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer; forward; function InvalidRegisterAndUnRegisterMemoryLeak(APointer: Pointer): Boolean; forward; {$endif} @@ -1109,7 +1479,7 @@ function InvalidRegisterAndUnRegisterMemoryLeak(APointer: Pointer): Boolean; for is used to serve medium blocks. The size must be a multiple of 16 and at least 4 bytes less than a multiple of 4K (the page size) to prevent a possible read access violation when reading past the end of a memory block - in the optimized move routine (MoveX16L4). In Full Debug mode we leave a + in the optimized move routine (MoveX16LP). In Full Debug mode we leave a trailing 256 bytes to be able to safely do a memory dump.} MediumBlockPoolSize = 20 * 64 * 1024{$ifndef FullDebugMode} - 16{$else} - 256{$endif}; {The granularity of small blocks} @@ -1188,38 +1558,28 @@ function InvalidRegisterAndUnRegisterMemoryLeak(APointer: Pointer): Boolean; for MediumInPlaceDownsizeLimit = MinimumMediumBlockSize div 4; {-------------Memory leak reporting constants---------------} ExpectedMemoryLeaksListSize = 64 * 1024; - {-------------FullDebugMode constants---------------} -{$ifdef FullDebugMode} - {The stack trace depth. (Must be an even number to ensure that the - Align16Bytes option works in FullDebugMode.)} - StackTraceDepth = 10; - {The number of entries in the allocation group stack} - AllocationGroupStackSize = 1000; - {The number of fake VMT entries - used to track virtual method calls on - freed objects. Do not change this value without also updating TFreedObject.GetVirtualMethodIndex} - MaxFakeVMTEntries = 200; - {The pattern used to fill unused memory} - DebugFillByte = $80; - DebugFillDWord = $01010101 * Cardinal(DebugFillByte); - {The address that is reserved so that accesses to the address of the fill - pattern will result in an A/V} - DebugReservedAddress = $01010000 * Cardinal(DebugFillByte); -{$endif} {-------------Other constants---------------} {$ifndef NeverSleepOnThreadContention} {Sleep time when a resource (small/medium/large block manager) is in use} InitialSleepTime = 0; {Used when the resource is still in use after the first sleep} - AdditionalSleepTime = 10; + AdditionalSleepTime = 1; {$endif} {Hexadecimal characters} HexTable: array[0..15] of AnsiChar = ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'); {Copyright message - not used anywhere in the code} - Copyright: AnsiString = 'FastMM4 (c) 2004 - 2008 Pierre le Riche / Professional Software Development'; + Copyright: AnsiString = 'FastMM4 (c) 2004 - 2011 Pierre le Riche / Professional Software Development'; {$ifdef FullDebugMode} {Virtual Method Called On Freed Object Errors} - StandardVirtualMethodNames: array[1 + vmtParent div 4 .. -1] of PAnsiChar = ( + StandardVirtualMethodNames: array[1 + vmtParent div SizeOf(Pointer) .. -1] of PAnsiChar = ( +{$ifdef BCB6OrDelphi6AndUp} + {$if RTLVersion >= 20} + 'Equals', + 'GetHashCode', + 'ToString', + {$ifend} +{$endif} 'SafeCallException', 'AfterConstruction', 'BeforeDestruction', @@ -1228,6 +1588,13 @@ function InvalidRegisterAndUnRegisterMemoryLeak(APointer: Pointer): Boolean; for 'NewInstance', 'FreeInstance', 'Destroy'); + {The name of the FullDebugMode support DLL. The support DLL implements stack + tracing and the conversion of addresses to unit and line number information.} +{$ifdef 32Bit} + FullDebugModeLibraryName = FullDebugModeLibraryName32Bit; +{$else} + FullDebugModeLibraryName = FullDebugModeLibraryName64Bit; +{$endif} {$endif} {-------------------------Private types----------------------------} @@ -1238,9 +1605,13 @@ function InvalidRegisterAndUnRegisterMemoryLeak(APointer: Pointer): Boolean; for PCardinal = ^Cardinal; PPointer = ^Pointer; {$endif} +{$ifdef BCB4} + {Define some additional types for BCB4} + PInteger = ^Integer; +{$endif} {Move procedure type} - TMoveProc = procedure(const ASource; var ADest; ACount: Integer); + TMoveProc = procedure(const ASource; var ADest; ACount: NativeInt); {Registers structure (for GetCPUID)} TRegisters = record @@ -1250,8 +1621,17 @@ TRegisters = record {The layout of a string allocation. Used to detect string leaks.} PStrRec = ^StrRec; StrRec = packed record - refCnt: Longint; - length: Longint; +{$ifdef 64Bit} + _Padding: Integer; +{$endif} +{$ifdef BCB6OrDelphi6AndUp} + {$if RTLVersion >= 20} + codePage: Word; + elemSize: Word; + {$ifend} +{$endif} + refCnt: Integer; + length: Integer; end; {$ifdef EnableMemoryLeakReporting} @@ -1265,118 +1645,121 @@ TRegisters = record {Pointer to the header of a small block pool} PSmallBlockPoolHeader = ^TSmallBlockPoolHeader; - {Small block type (Size = 32)} + {Small block type (Size = 32 bytes for 32-bit, 64 bytes for 64-bit).} PSmallBlockType = ^TSmallBlockType; - TSmallBlockType = packed record + TSmallBlockType = record {True = Block type is locked} BlockTypeLocked: Boolean; {Bitmap indicating which of the first 8 medium block groups contain blocks of a suitable size for a block pool.} - AllowedGroupsForBlockPoolBitmap: byte; + AllowedGroupsForBlockPoolBitmap: Byte; {The block size for this block type} BlockSize: Word; - {The first partially free pool for the given small block type (offset = +4 - for typecast compatibility with TSmallBlockPoolHeader). This is a circular - buffer.} + {The minimum and optimal size of a small block pool for this block type} + MinimumBlockPoolSize: Word; + OptimalBlockPoolSize: Word; + {The first partially free pool for the given small block. This field must + be at the same offset as TSmallBlockPoolHeader.NextPartiallyFreePool.} NextPartiallyFreePool: PSmallBlockPoolHeader; - {The offset of the last block that was served sequentially (0ffset = +8 to - to be at the same offset as the "FirstFreeBlock" of TSmallBlockPoolHeader} + {The last partially free pool for the small block type. This field must + be at the same offset as TSmallBlockPoolHeader.PreviousPartiallyFreePool.} + PreviousPartiallyFreePool: PSmallBlockPoolHeader; + {The offset of the last block that was served sequentially. The field must + be at the same offset as TSmallBlockPoolHeader.FirstFreeBlock.} NextSequentialFeedBlockAddress: Pointer; - {The last block that can be served sequentially. Offset is at +12 to be - at the same address as the "BlocksInUse" field of TSmallBlockPoolHeader} + {The last block that can be served sequentially.} MaxSequentialFeedBlockAddress: Pointer; {The pool that is current being used to serve blocks in sequential order} CurrentSequentialFeedPool: PSmallBlockPoolHeader; - {The previous partially free pool for the small block type (offset = +20 - for typecast compatibility with TSmallBlockPoolHeader)} - PreviousPartiallyFreePool: PSmallBlockPoolHeader; - {The minimum and optimal size of a small block pool for this block type} - MinimumBlockPoolSize: Word; - OptimalBlockPoolSize: Word; {$ifdef UseCustomFixedSizeMoveRoutines} {The fixed size move procedure used to move data for this block size when it is upsized. When a block is downsized (which usually does not occur that often) the variable size move routine is used.} UpsizeMoveProcedure: TMoveProc; {$else} - Reserved1: Cardinal; + Reserved1: Pointer; +{$endif} +{$ifdef 64Bit} + {Pad to 64 bytes for 64-bit} + Reserved2: Pointer; {$endif} end; - {Small block pool (Size = 32 bytes)} - TSmallBlockPoolHeader = packed record + {Small block pool (Size = 32 bytes for 32-bit, 48 bytes for 64-bit).} + TSmallBlockPoolHeader = record {BlockType} BlockType: PSmallBlockType; - {The next pool that has free blocks of this size. Must be at offset +4 - to be typecast compatible with TSmallBlockType} +{$ifdef 32Bit} + {Align the next fields to the same fields in TSmallBlockType and pad this + structure to 32 bytes for 32-bit} + Reserved1: Cardinal; +{$endif} + {The next and previous pool that has free blocks of this size. Do not + change the position of these two fields: They must be at the same offsets + as the fields in TSmallBlockType of the same name.} NextPartiallyFreePool: PSmallBlockPoolHeader; - {Pointer to the first free block inside this pool. Must be at offset + 8 - to be at the same offset as "NextSequentialFeedBlockAddress" of - TSmallBlockType} + PreviousPartiallyFreePool: PSmallBlockPoolHeader; + {Pointer to the first free block inside this pool. This field must be at + the same offset as TSmallBlockType.NextSequentialFeedBlockAddress.} FirstFreeBlock: Pointer; - {The number of blocks allocated in this pool. Must be at offset + 12 - to be at the same offset as "MaxSequentialFeedBlockAddress" of - TSmallBlockType} + {The number of blocks allocated in this pool.} BlocksInUse: Cardinal; - {Reserved} - Reserved1: Cardinal; - {The previous pool that has free blocks of this size. Must be at offset +20 - to be compatible with TSmallBlockType} - PreviousPartiallyFreePool: PSmallBlockPoolHeader; - {Reserved} + {Padding} Reserved2: Cardinal; {The pool pointer and flags of the first block} - FirstBlockPoolPointerAndFlags: Cardinal; + FirstBlockPoolPointerAndFlags: NativeUInt; end; {Small block layout: - Offset: -4 = Flags + address of the small block pool - Offset: BlockSize - 4 = Flags + address of the small block pool for the next small block + At offset -SizeOf(Pointer) = Flags + address of the small block pool. + At offset BlockSize - SizeOf(Pointer) = Flags + address of the small block + pool for the next small block. } - {----------------------Medium block structures----------------------} + {------------------------Medium block structures------------------------} - {The medium block pool from which medium blocks are drawn} + {The medium block pool from which medium blocks are drawn. Size = 16 bytes + for 32-bit and 32 bytes for 64-bit.} PMediumBlockPoolHeader = ^TMediumBlockPoolHeader; - TMediumBlockPoolHeader = packed record + TMediumBlockPoolHeader = record {Points to the previous and next medium block pools. This circular linked list is used to track memory leaks on program shutdown.} PreviousMediumBlockPoolHeader: PMediumBlockPoolHeader; NextMediumBlockPoolHeader: PMediumBlockPoolHeader; - {Unused dword} - Reserved: Cardinal; + {Padding} + Reserved1: NativeUInt; {The block size and flags of the first medium block in the block pool} - FirstMediumBlockSizeAndFlags: Cardinal; + FirstMediumBlockSizeAndFlags: NativeUInt; end; {Medium block layout: - Offset: -8 = Previous Block Size (only if the previous block is free) - Offset: -4 = This block size and flags + Offset: -2 * SizeOf(Pointer) = Previous Block Size (only if the previous block is free) + Offset: -SizeOf(Pointer) = This block size and flags Offset: 0 = User data / Previous Free Block (if this block is free) - Offset: 4 = Next Free Block (if this block is free) - Offset: BlockSize - 8 = Size of this block (if this block is free) - Offset: BlockSize - 4 = Size of the next block and flags + Offset: SizeOf(Pointer) = Next Free Block (if this block is free) + Offset: BlockSize - 2*SizeOf(Pointer) = Size of this block (if this block is free) + Offset: BlockSize - SizeOf(Pointer) = Size of the next block and flags {A medium block that is unused} PMediumFreeBlock = ^TMediumFreeBlock; - TMediumFreeBlock = packed record + TMediumFreeBlock = record PreviousFreeBlock: PMediumFreeBlock; NextFreeBlock: PMediumFreeBlock; end; - {-------------------------Large block structures--------------------} + {-------------------------Large block structures------------------------} - {Large block header record (size = 16)} + {Large block header record (Size = 16 for 32-bit, 32 for 64-bit)} PLargeBlockHeader = ^TLargeBlockHeader; - TLargeBlockHeader = packed record + TLargeBlockHeader = record {Points to the previous and next large blocks. This circular linked list is used to track memory leaks on program shutdown.} PreviousLargeBlockHeader: PLargeBlockHeader; NextLargeBlockHeader: PLargeBlockHeader; {The user allocated size of the Large block} - UserAllocatedSize: Cardinal; + UserAllocatedSize: NativeUInt; {The size of this block plus the flags} - BlockSizeAndFlags: Cardinal; + BlockSizeAndFlags: NativeUInt; end; {-------------------------Expected Memory Leak Structures--------------------} @@ -1387,7 +1770,7 @@ TRegisters = record not.} PExpectedMemoryLeak = ^TExpectedMemoryLeak; PPExpectedMemoryLeak = ^PExpectedMemoryLeak; - TExpectedMemoryLeak = packed record + TExpectedMemoryLeak = record {Linked list pointers} PreviousLeak, NextLeak: PExpectedMemoryLeak; {Information about the expected leak} @@ -1396,11 +1779,11 @@ TRegisters = record {$ifdef CheckCppObjectTypeEnabled} LeakedCppTypeIdPtr: Pointer; {$endif} - LeakSize: Integer; + LeakSize: NativeInt; LeakCount: Integer; end; - TExpectedMemoryLeaks = packed record + TExpectedMemoryLeaks = record {The number of entries used in the expected leaks buffer} EntriesUsed: Integer; {Freed entries} @@ -1411,110 +1794,57 @@ TRegisters = record FirstEntryByClass: PExpectedMemoryLeak; {Entries with only size specified} FirstEntryBySizeOnly: PExpectedMemoryLeak; - {The expected leaks buffer} - ExpectedLeaks: packed array[0..(ExpectedMemoryLeaksListSize - 20) div SizeOf(TExpectedMemoryLeak) - 1] of TExpectedMemoryLeak; + {The expected leaks buffer (Need to leave space for this header)} + ExpectedLeaks: array[0..(ExpectedMemoryLeaksListSize - 64) div SizeOf(TExpectedMemoryLeak) - 1] of TExpectedMemoryLeak; end; PExpectedMemoryLeaks = ^TExpectedMemoryLeaks; {$endif} - {-------------------------Full Debug Mode Structures--------------------} +{-------------------------Private constants----------------------------} +const +{$ifndef BCB6OrDelphi7AndUp} + reOutOfMemory = 1; + reInvalidPtr = 2; +{$endif} + {The size of the block header in front of small and medium blocks} + BlockHeaderSize = SizeOf(Pointer); + {The size of a small block pool header} + SmallBlockPoolHeaderSize = SizeOf(TSmallBlockPoolHeader); + {The size of a medium block pool header} + MediumBlockPoolHeaderSize = SizeOf(TMediumBlockPoolHeader); + {The size of the header in front of Large blocks} + LargeBlockHeaderSize = SizeOf(TLargeBlockHeader); {$ifdef FullDebugMode} - - PStackTrace = ^TStackTrace; - TStackTrace = array[0..StackTraceDepth - 1] of Cardinal; - - TBlockOperation = (boBlockCheck, boGetMem, boFreeMem, boReallocMem); - - {The header placed in front blocks in FullDebugMode (just after the standard - header). Must be a multiple of 16 bytes in size otherwise the Align16Bytes - option will not work.} - PFullDebugBlockHeader = ^TFullDebugBlockHeader; - TFullDebugBlockHeader = packed record - {Space used by the medium block manager for previous/next block management. - If a medium block is binned then these two dwords will be modified.} - Reserved1: Cardinal; - Reserved2: Cardinal; - {Is the block currently allocated?} - BlockInUse: LongBool; - {The allocation group: Can be used in the debugging process to group - related memory leaks together} - AllocationGroup: Cardinal; - {The allocation number: All new allocations are numbered sequentially. This - number may be useful in memory leak analysis. If it reaches 4GB it wraps - back to 0.} - AllocationNumber: Cardinal; - {The call stack when the block was allocated} - AllocationStackTrace: TStackTrace; - {The call stack when the block was freed} - FreeStackTrace: TStackTrace; - {The user requested size for the block. 0 if this is the first time the - block is used.} - UserSize: Cardinal; - {The object class this block was used for the previous time it was - allocated. When a block is freed, the dword that would normally be in the - space of the class pointer is copied here, so if it is detected that - the block was used after being freed we have an idea what class it is.} - PreviouslyUsedByClass: Cardinal; - {The sum of all the dwords excluding reserved dwords.} - HeaderCheckSum: Cardinal; - end; - {The last four bytes of the actual allocated block is the inverse of the - header checksum} - - {The class used to catch attempts to execute a virtual method of a freed - object} - TFreedObject = class - public - procedure GetVirtualMethodIndex; - procedure VirtualMethodError; -{$ifdef CatchUseOfFreedInterfaces} - procedure InterfaceError; -{$endif} - end; - -{$endif} - -{-------------------------Private constants----------------------------} -const -{$ifndef BCB6OrDelphi7AndUp} - reInvalidPtr = 2; -{$endif} - {The size of the block header in front of small and medium blocks} - BlockHeaderSize = 4; - {The size of a small block pool header} - SmallBlockPoolHeaderSize = SizeOf(TSmallBlockPoolHeader); - {The size of a medium block pool header} - MediumBlockPoolHeaderSize = SizeOf(TMediumBlockPoolHeader); - {The size of the header in front of Large blocks} - LargeBlockHeaderSize = SizeOf(TLargeBlockHeader); -{$ifdef FullDebugMode} - {We need space for the header. 4 bytes for the trailer and 4 bytes for the - trailing block size when the block is free} - FullDebugBlockOverhead = SizeOf(TFullDebugBlockHeader) + 2 * SizeOf(Pointer); -{$endif} + {We need space for the header, the trailer checksum and the trailing block + size (only used by freed medium blocks).} + FullDebugBlockOverhead = SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt) + SizeOf(Pointer); +{$endif} {-------------------------Private variables----------------------------} var {-----------------Small block management------------------} - {The small block types. Sizes include the leading 4-byte header. Sizes are + {The small block types. Sizes include the leading header. Sizes are picked to limit maximum wastage to about 10% or 256 bytes (whichever is less) where possible.} - SmallBlockTypes: packed array[0..NumSmallBlockTypes - 1] of TSmallBlockType =( + SmallBlockTypes: array[0..NumSmallBlockTypes - 1] of TSmallBlockType =( {8/16 byte jumps} - (BlockSize: 16 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move12{$endif}), +{$ifndef Align16Bytes} + (BlockSize: 8 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move4{$endif}), +{$endif} + (BlockSize: 16 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: {$ifdef 32Bit}Move12{$else}Move8{$endif}{$endif}), {$ifndef Align16Bytes} (BlockSize: 24 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move20{$endif}), {$endif} - (BlockSize: 32 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move28{$endif}), + (BlockSize: 32 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: {$ifdef 32Bit}Move28{$else}Move24{$endif}{$endif}), {$ifndef Align16Bytes} (BlockSize: 40 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move36{$endif}), {$endif} - (BlockSize: 48 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move44{$endif}), + (BlockSize: 48 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: {$ifdef 32Bit}Move44{$else}Move40{$endif}{$endif}), {$ifndef Align16Bytes} (BlockSize: 56 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move52{$endif}), {$endif} - (BlockSize: 64 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move60{$endif}), + (BlockSize: 64 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: {$ifdef 32Bit}Move60{$else}Move56{$endif}{$endif}), {$ifndef Align16Bytes} (BlockSize: 72 {$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move68{$endif}), {$endif} @@ -1594,7 +1924,7 @@ TFreedObject = class (BlockSize: MaximumSmallBlockSize), (BlockSize: MaximumSmallBlockSize)); {Size to small block type translation table} - AllocSize2SmallBlockTypeIndX4: packed array[0..(MaximumSmallBlockSize - 1) div SmallBlockGranularity] of Byte; + AllocSize2SmallBlockTypeIndX4: array[0..(MaximumSmallBlockSize - 1) div SmallBlockGranularity] of Byte; {-----------------Medium block management------------------} {A dummy medium block pool header: Maintains a circular list of all medium block pools to enable memory leak detection on program shutdown.} @@ -1610,12 +1940,12 @@ TFreedObject = class MediumBlockBinGroupBitmap: Cardinal; {The medium block bins: total of 32 * 32 = 1024 bins of a certain minimum size.} - MediumBlockBinBitmaps: packed array[0..MediumBlockBinGroupCount - 1] of Cardinal; + MediumBlockBinBitmaps: array[0..MediumBlockBinGroupCount - 1] of Cardinal; {The medium block bins. There are 1024 LIFO circular linked lists each holding blocks of a specified minimum size. The sizes vary in size from MinimumMediumBlockSize to MaximumMediumBlockSize. The bins are treated as type TMediumFreeBlock to avoid pointer checks.} - MediumBlockBins: packed array[0..MediumBlockBinCount - 1] of TMediumFreeBlock; + MediumBlockBins: array[0..MediumBlockBinCount - 1] of TMediumFreeBlock; {-----------------Large block management------------------} {Are large blocks locked?} LargeBlocksLocked: Boolean; @@ -1636,6 +1966,12 @@ TFreedObject = class AllocationGroupStackTop: Cardinal; {The last allocation number used} CurrentAllocationNumber: Cardinal; + {This is a count of the number of threads currently inside any of the + FullDebugMode GetMem, Freemem or ReallocMem handlers. If this value + is negative then a block scan is in progress and no thread may + allocate, free or reallocate any block or modify any FullDebugMode + block header or footer.} + ThreadsInFullDebugModeRoutine: Integer; {The current log file name} MMLogFileName: array[0..1023] of AnsiChar; {The 64K block of reserved memory used to trap invalid memory accesses using @@ -1646,8 +1982,8 @@ TFreedObject = class VMIndex: Integer; {The fake VMT used to catch virtual method calls on freed objects.} FreedObjectVMT: packed record - VMTData: array[vmtSelfPtr .. vmtParent + 3] of byte; - VMTMethods: array[4 + vmtParent .. MaxFakeVMTEntries * 4 + vmtParent + 3] of Byte; + VMTData: array[vmtSelfPtr .. vmtParent + SizeOf(Pointer) - 1] of byte; + VMTMethods: array[SizeOf(Pointer) + vmtParent .. vmtParent + MaxFakeVMTEntries * SizeOf(Pointer) + SizeOf(Pointer) - 1] of Byte; end; {$ifdef CatchUseOfFreedInterfaces} VMTBadInterface: array[0..MaxFakeVMTEntries - 1] of Pointer; @@ -1690,7 +2026,7 @@ TFreedObject = class MMWindowBE: HWND; {$endif} {The handle of the memory mapped file} - MappingObjectHandle: Cardinal; + MappingObjectHandle: NativeUInt; {$endif} {Has FastMM been installed?} FastMMIsInstalled: Boolean; @@ -1704,12 +2040,21 @@ TFreedObject = class {$endif} {Is a MessageBox currently showing? If so, do not show another one.} ShowingMessageBox: Boolean; + {True if RunInitializationCode has been called already.} + InitializationCodeHasRun: Boolean = False; {----------------Utility Functions------------------} -{A copy StrLen in order to avoid the SysUtils unit, which would have introduced - overhead like exception handling code.} -function StrLen(const Str: PAnsiChar): Cardinal; +{A copy of StrLen in order to avoid the SysUtils unit, which would have + introduced overhead like exception handling code.} +function StrLen(const AStr: PAnsiChar): NativeUInt; +{$ifndef Use32BitAsm} +begin + Result := 0; + while AStr[Result] <> #0 do + Inc(Result); +end; +{$else} asm {Check the first byte} cmp byte ptr [eax], 0 @@ -1737,6 +2082,7 @@ function StrLen(const Str: PAnsiChar): Cardinal; @ZeroLength: xor eax, eax end; +{$endif} {$ifdef EnableMMX} {$ifndef ForceMMX} @@ -1797,26 +2143,38 @@ function MMX_Supported: Boolean; {Compare [AAddress], CompareVal: If Equal: [AAddress] := NewVal and result = CompareVal If Unequal: Result := [AAddress]} -function LockCmpxchg(CompareVal, NewVal: byte; AAddress: PByte): Byte; +function LockCmpxchg(CompareVal, NewVal: Byte; AAddress: PByte): Byte; asm +{$ifdef 32Bit} {On entry: al = CompareVal, dl = NewVal, ecx = AAddress} -{$ifndef Linux} + {$ifndef Linux} lock cmpxchg [ecx], dl -{$else} + {$else} {Workaround for Kylix compiler bug} db $F0, $0F, $B0, $11 + {$endif} +{$else} + {On entry: + cl = CompareVal + dl = NewVal + r8 = AAddress} + .noframe + mov rax, rcx + lock cmpxchg [r8], dl {$endif} end; -{$ifndef AsmVersion} -{Gets the first set bit and resets it, returning the bit index} +{$ifndef ASMVersion} +{Gets the first set bit in the 32-bit number, returning the bit index} function FindFirstSetBit(ACardinal: Cardinal): Cardinal; asm - {On entry: - eax = ACardinal} +{$ifdef 64Bit} + .noframe + mov rax, rcx +{$endif} bsf eax, eax end; {$endif} @@ -1835,7 +2193,11 @@ function AppendModuleFileName(ABuffer: PAnsiChar): Integer; {$endif} LModuleHandle := 0; {Get the module name} +{$ifndef Linux} Result := GetModuleFileNameA(LModuleHandle, ABuffer, 512); +{$else} + Result := GetModuleFileName(LModuleHandle, ABuffer, 512); +{$endif} end; {Copies the name of the module followed by the given string to the buffer, @@ -1851,9 +2213,9 @@ function AppendStringToModuleName(AString, ABuffer: PAnsiChar): PAnsiChar; if LModuleNameLength > 0 then begin {Find the last backslash} - LCopyStart := PAnsiChar(Cardinal(ABuffer) + LModuleNameLength - 1); + LCopyStart := PAnsiChar(PByte(ABuffer) + LModuleNameLength - 1); LModuleNameLength := 0; - while (Cardinal(LCopyStart) >= Cardinal(ABuffer)) + while (UIntPtr(LCopyStart) >= UIntPtr(ABuffer)) and (LCopyStart^ <> '\') do begin Inc(LModuleNameLength); @@ -1885,18 +2247,47 @@ function AppendStringToModuleName(AString, ABuffer: PAnsiChar): PAnsiChar; {Fixed size move operations ignore the size parameter. All moves are assumed to be non-overlapping.} -procedure Move12(const ASource; var ADest; ACount: Integer); +procedure Move4(const ASource; var ADest; ACount: NativeInt); +asm +{$ifdef 32Bit} + mov eax, [eax] + mov [edx], eax +{$else} +.noframe + mov eax, [rcx] + mov [rdx], eax +{$endif} +end; + +{$ifdef 64Bit} +procedure Move8(const ASource; var ADest; ACount: NativeInt); asm + mov rax, [rcx] + mov [rdx], rax +end; +{$endif} + +procedure Move12(const ASource; var ADest; ACount: NativeInt); +asm +{$ifdef 32Bit} mov ecx, [eax] mov [edx], ecx mov ecx, [eax + 4] mov eax, [eax + 8] mov [edx + 4], ecx mov [edx + 8], eax +{$else} +.noframe + mov rax, [rcx] + mov ecx, [rcx + 8] + mov [rdx], rax + mov [rdx + 8], ecx +{$endif} end; -procedure Move20(const ASource; var ADest; ACount: Integer); +procedure Move20(const ASource; var ADest; ACount: NativeInt); asm +{$ifdef 32Bit} mov ecx, [eax] mov [edx], ecx mov ecx, [eax + 4] @@ -1907,10 +2298,28 @@ procedure Move20(const ASource; var ADest; ACount: Integer); mov eax, [eax + 16] mov [edx + 12], ecx mov [edx + 16], eax +{$else} +.noframe + movdqa xmm0, [rcx] + mov ecx, [rcx + 16] + movdqa [rdx], xmm0 + mov [rdx + 16], ecx +{$endif} end; -procedure Move28(const ASource; var ADest; ACount: Integer); +{$ifdef 64Bit} +procedure Move24(const ASource; var ADest; ACount: NativeInt); asm + movdqa xmm0, [rcx] + mov r8, [rcx + 16] + movdqa [rdx], xmm0 + mov [rdx + 16], r8 +end; +{$endif} + +procedure Move28(const ASource; var ADest; ACount: NativeInt); +asm +{$ifdef 32Bit} mov ecx, [eax] mov [edx], ecx mov ecx, [eax + 4] @@ -1925,10 +2334,20 @@ procedure Move28(const ASource; var ADest; ACount: Integer); mov eax, [eax + 24] mov [edx + 20], ecx mov [edx + 24], eax +{$else} +.noframe + movdqa xmm0, [rcx] + mov r8, [rcx + 16] + mov ecx, [rcx + 24] + movdqa [rdx], xmm0 + mov [rdx + 16], r8 + mov [rdx + 24], ecx +{$endif} end; -procedure Move36(const ASource; var ADest; ACount: Integer); +procedure Move36(const ASource; var ADest; ACount: NativeInt); asm +{$ifdef 32Bit} fild qword ptr [eax] fild qword ptr [eax + 8] fild qword ptr [eax + 16] @@ -1939,10 +2358,32 @@ procedure Move36(const ASource; var ADest; ACount: Integer); fistp qword ptr [edx + 16] fistp qword ptr [edx + 8] fistp qword ptr [edx] +{$else} +.noframe + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + mov ecx, [rcx + 32] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + mov [rdx + 32], ecx +{$endif} end; -procedure Move44(const ASource; var ADest; ACount: Integer); +{$ifdef 64Bit} +procedure Move40(const ASource; var ADest; ACount: NativeInt); asm + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + mov r8, [rcx + 32] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + mov [rdx + 32], r8 +end; +{$endif} + +procedure Move44(const ASource; var ADest; ACount: NativeInt); +asm +{$ifdef 32Bit} fild qword ptr [eax] fild qword ptr [eax + 8] fild qword ptr [eax + 16] @@ -1955,10 +2396,22 @@ procedure Move44(const ASource; var ADest; ACount: Integer); fistp qword ptr [edx + 16] fistp qword ptr [edx + 8] fistp qword ptr [edx] +{$else} +.noframe + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + mov r8, [rcx + 32] + mov ecx, [rcx + 40] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + mov [rdx + 32], r8 + mov [rdx + 40], ecx +{$endif} end; -procedure Move52(const ASource; var ADest; ACount: Integer); +procedure Move52(const ASource; var ADest; ACount: NativeInt); asm +{$ifdef 32Bit} fild qword ptr [eax] fild qword ptr [eax + 8] fild qword ptr [eax + 16] @@ -1973,10 +2426,36 @@ procedure Move52(const ASource; var ADest; ACount: Integer); fistp qword ptr [edx + 16] fistp qword ptr [edx + 8] fistp qword ptr [edx] +{$else} +.noframe + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + movdqa xmm2, [rcx + 32] + mov ecx, [rcx + 48] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + movdqa [rdx + 32], xmm2 + mov [rdx + 48], ecx +{$endif} end; -procedure Move60(const ASource; var ADest; ACount: Integer); +{$ifdef 64Bit} +procedure Move56(const ASource; var ADest; ACount: NativeInt); asm + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + movdqa xmm2, [rcx + 32] + mov r8, [rcx + 48] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + movdqa [rdx + 32], xmm2 + mov [rdx + 48], r8 +end; +{$endif} + +procedure Move60(const ASource; var ADest; ACount: NativeInt); +asm +{$ifdef 32Bit} fild qword ptr [eax] fild qword ptr [eax + 8] fild qword ptr [eax + 16] @@ -1993,10 +2472,24 @@ procedure Move60(const ASource; var ADest; ACount: Integer); fistp qword ptr [edx + 16] fistp qword ptr [edx + 8] fistp qword ptr [edx] +{$else} +.noframe + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + movdqa xmm2, [rcx + 32] + mov r8, [rcx + 48] + mov ecx, [rcx + 56] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + movdqa [rdx + 32], xmm2 + mov [rdx + 48], r8 + mov [rdx + 56], ecx +{$endif} end; -procedure Move68(const ASource; var ADest; ACount: Integer); +procedure Move68(const ASource; var ADest; ACount: NativeInt); asm +{$ifdef 32Bit} fild qword ptr [eax] fild qword ptr [eax + 8] fild qword ptr [eax + 16] @@ -2015,12 +2508,28 @@ procedure Move68(const ASource; var ADest; ACount: Integer); fistp qword ptr [edx + 16] fistp qword ptr [edx + 8] fistp qword ptr [edx] +{$else} +.noframe + movdqa xmm0, [rcx] + movdqa xmm1, [rcx + 16] + movdqa xmm2, [rcx + 32] + movdqa xmm3, [rcx + 48] + mov ecx, [rcx + 64] + movdqa [rdx], xmm0 + movdqa [rdx + 16], xmm1 + movdqa [rdx + 32], xmm2 + movdqa [rdx + 48], xmm3 + mov [rdx + 64], ecx +{$endif} end; -{Variable size move procedure: Assumes ACount is 4 less than a multiple of 16. - Always moves at least 12 bytes, irrespective of ACount.} -procedure MoveX16L4(const ASource; var ADest; ACount: Integer); +{Variable size move procedure: Rounds ACount up to the next multiple of 16 less + SizeOf(Pointer). Important note: Always moves at least 16 - SizeOf(Pointer) + bytes (the minimum small block size with 16 byte alignment), irrespective of + ACount.} +procedure MoveX16LP(const ASource; var ADest; ACount: NativeInt); asm +{$ifdef 32Bit} {Make the counter negative based: The last 12 bytes are moved separately} sub ecx, 12 add eax, ecx @@ -2098,14 +2607,39 @@ procedure MoveX16L4(const ASource; var ADest; ACount: Integer); mov eax, [eax + ecx + 8] mov [edx + ecx + 8], eax {$endif} +{$else} +.noframe + {Make the counter negative based: The last 8 bytes are moved separately} + sub r8, 8 + add rcx, r8 + add rdx, r8 + neg r8 + jns @MoveLast12 +@MoveLoop: + {Move a 16 byte block} + movdqa xmm0, [rcx + r8] + movdqa [rdx + r8], xmm0 + {Are there another 16 bytes to move?} + add r8, 16 + js @MoveLoop +@MoveLast12: + {Do the last 8 bytes} + mov r9, [rcx + r8] + mov [rdx + r8], r9 +{$endif} end; -{Variable size move procedure: Assumes ACount is 4 less than a multiple of 8. - Always moves at least 12 bytes, irrespective of ACount.} -procedure MoveX8L4(const ASource; var ADest; ACount: Integer); +{Variable size move procedure: Rounds ACount up to the next multiple of 8 less + SizeOf(Pointer). Important note: Always moves at least 8 - SizeOf(Pointer) + bytes (the minimum small block size with 8 byte alignment), irrespective of + ACount.} +procedure MoveX8LP(const ASource; var ADest; ACount: NativeInt); asm +{$ifdef 32Bit} {Make the counter negative based: The last 4 bytes are moved separately} sub ecx, 4 + {4 bytes or less? -> Use the Move4 routine.} + jle @FourBytesOrLess add eax, ecx add edx, ecx neg ecx @@ -2137,9 +2671,7 @@ procedure MoveX8L4(const ASource; var ADest; ACount: Integer); {Do the last 4 bytes} mov eax, [eax + ecx] mov [edx + ecx], eax - {$ifndef ForceMMX} ret - {$endif} {$endif} {FPU code is only used if MMX is not forced} {$ifndef ForceMMX} @@ -2153,6 +2685,25 @@ procedure MoveX8L4(const ASource; var ADest; ACount: Integer); {Do the last 4 bytes} mov eax, [eax + ecx] mov [edx + ecx], eax + ret +{$endif} +@FourBytesOrLess: + {Four or less bytes to move} + mov eax, [eax] + mov [edx], eax +{$else} +.noframe + {Make the counter negative based} + add rcx, r8 + add rdx, r8 + neg r8 +@MoveLoop: + {Move an 8 byte block} + mov r9, [rcx + r8] + mov [rdx + r8], r9 + {Are there another 8 bytes to move?} + add r8, 8 + js @MoveLoop {$endif} end; @@ -2201,12 +2752,27 @@ procedure Sleep(dwMilliseconds: Cardinal); stdcall; {$ifdef FullDebugMode} -{Fills a block of memory with the given dword. Always fills a multiple of 4 bytes} -procedure FillDWord(var AAddress; AByteCount: Integer; ADWordFillValue: Cardinal); +{Returns the current thread ID} +function GetThreadID: Cardinal; +{$ifdef 32Bit} +asm + mov eax, FS:[$24] +end; +{$else} +begin + Result := GetCurrentThreadId; +end; +{$endif} + +{Fills a block of memory with the given dword (32-bit) or qword (64-bit). + Always fills a multiple of SizeOf(Pointer) bytes} +procedure DebugFillMem(var AAddress; AByteCount: NativeInt; AFillValue: NativeUInt); asm - {On Entry: eax = AAddress +{$ifdef 32Bit} + {On Entry: + eax = AAddress edx = AByteCount - ecx = ADWordFillValue} + ecx = AFillValue} add eax, edx neg edx jns @Done @@ -2215,6 +2781,20 @@ procedure FillDWord(var AAddress; AByteCount: Integer; ADWordFillValue: Cardinal add edx, 4 js @FillLoop @Done: +{$else} + {On Entry: + rcx = AAddress + rdx = AByteCount + r8 = AFillValue} + add rcx, rdx + neg rdx + jns @Done +@FillLoop: + mov [rcx + rdx], r8 + add rdx, 8 + js @FillLoop +@Done: +{$endif} end; {$ifndef LoadDebugDLLDynamically} @@ -2222,26 +2802,26 @@ procedure FillDWord(var AAddress; AByteCount: Integer; ADWordFillValue: Cardinal {The stack trace procedure. The stack trace module is external since it may raise handled access violations that result in the creation of exception objects and the stack trace code is not re-entrant.} -procedure GetStackTrace(AReturnAddresses: PCardinal; +procedure GetStackTrace(AReturnAddresses: PNativeUInt; AMaxDepth, ASkipFrames: Cardinal); external FullDebugModeLibraryName name {$ifdef RawStackTraces}'GetRawStackTrace'{$else}'GetFrameBasedStackTrace'{$endif}; {The exported procedure in the FastMM_FullDebugMode.dll library used to convert the return addresses of a stack trace to a text string.} -function LogStackTrace(AReturnAddresses: PCardinal; +function LogStackTrace(AReturnAddresses: PNativeUInt; AMaxDepth: Cardinal; ABuffer: PAnsiChar): PAnsiChar; external FullDebugModeLibraryName name 'LogStackTrace'; {$else} {Default no-op stack trace and logging handlers} - procedure NoOpGetStackTrace(AReturnAddresses: PCardinal; + procedure NoOpGetStackTrace(AReturnAddresses: PNativeUInt; AMaxDepth, ASkipFrames: Cardinal); begin - FillDWord(AReturnAddresses^, AMaxDepth * 4, 0); + DebugFillMem(AReturnAddresses^, AMaxDepth * SizeOf(Pointer), 0); end; - function NoOpLogStackTrace(AReturnAddresses: PCardinal; + function NoOpLogStackTrace(AReturnAddresses: PNativeUInt; AMaxDepth: Cardinal; ABuffer: PAnsiChar): PAnsiChar; begin Result := ABuffer; @@ -2252,10 +2832,10 @@ function LogStackTrace(AReturnAddresses: PCardinal; {Handle to the FullDebugMode DLL} FullDebugModeDLL: HMODULE; - GetStackTrace: procedure (AReturnAddresses: PCardinal; + GetStackTrace: procedure (AReturnAddresses: PNativeUInt; AMaxDepth, ASkipFrames: Cardinal) = NoOpGetStackTrace; - LogStackTrace: function (AReturnAddresses: PCardinal; + LogStackTrace: function (AReturnAddresses: PNativeUInt; AMaxDepth: Cardinal; ABuffer: PAnsiChar): PAnsiChar = NoOpLogStackTrace; {$endif} @@ -2269,128 +2849,174 @@ function DelphiIsRunning: Boolean; end; {$endif} -{Converts a cardinal to string at the buffer location, returning the new - buffer position.} -function CardinalToStrBuf(ACardinal: Cardinal; ABuffer: PAnsiChar): PAnsiChar; +{Converts an unsigned integer to string at the buffer location, returning the + new buffer position. Note: The 32-bit asm version only supports numbers up to + 2^31 - 1.} +function NativeUIntToStrBuf(ANum: NativeUInt; APBuffer: PAnsiChar): PAnsiChar; +{$ifndef Use32BitAsm} +const + MaxDigits = 20; +var + LDigitBuffer: array[0..MaxDigits - 1] of AnsiChar; + LCount: Cardinal; + LDigit: NativeUInt; +begin + {Generate the digits in the local buffer} + LCount := 0; + repeat + LDigit := ANum; + ANum := ANum div 10; + LDigit := LDigit - ANum * 10; + Inc(LCount); + LDigitBuffer[MaxDigits - LCount] := AnsiChar(Ord('0') + LDigit); + until ANum = 0; + {Copy the digits to the output buffer and advance it} + System.Move(LDigitBuffer[MaxDigits - LCount], APBuffer^, LCount); + Result := APBuffer + LCount; +end; +{$else} asm - {On entry: eax = ACardinal, edx = ABuffer} + {On entry: eax = ANum, edx = ABuffer} push edi - mov edi, edx //Pointer to the first character in edi - //Calculate leading digit: divide the number by 1e9 - add eax, 1 //Increment the number - mov edx, $89705F41 //1e9 reciprocal - mul edx //Multplying with reciprocal - shr eax, 30 //Save fraction bits - mov ecx, edx //First digit in bits <31:29> - and edx, $1FFFFFFF //Filter fraction part edx<28:0> - shr ecx, 29 //Get leading digit into accumulator - lea edx, [edx+4*edx] //Calculate ... - add edx, eax //... 5*fraction - mov eax, ecx //Copy leading digit - or eax, '0' //Convert digit to ASCII - mov [edi], al //Store digit out to memory - //Calculate digit #2 - mov eax, edx //Point format such that 1.0 = 2^28 - cmp ecx, 1 //Any non-zero digit yet ? - sbb edi, -1 //Yes->increment ptr, No->keep old ptr - shr eax, 28 //Next digit - and edx, $0fffffff //Fraction part edx<27:0> - or ecx, eax //Accumulate next digit - or eax, '0' //Convert digit to ASCII - mov [edi], al //Store digit out to memory - //Calculate digit #3 - lea eax, [edx*4+edx] //5*fraction, new digit eax<31:27> - lea edx, [edx*4+edx] //5*fraction, new fraction edx<26:0> - cmp ecx, 1 //Any non-zero digit yet ? - sbb edi, -1 //Yes->increment ptr, No->keep old ptr - shr eax, 27 //Next digit - and edx, $07ffffff //Fraction part - or ecx, eax //Accumulate next digit - or eax, '0' //Convert digit to ASCII - mov [edi], al //Store digit out to memory - //Calculate digit #4 - lea eax, [edx*4+edx] //5*fraction, new digit eax<31:26> - lea edx, [edx*4+edx] //5*fraction, new fraction edx<25:0> - cmp ecx, 1 //Any non-zero digit yet ? - sbb edi, -1 //Yes->increment ptr, No->keep old ptr - shr eax, 26 //Next digit - and edx, $03ffffff //Fraction part - or ecx, eax //Accumulate next digit - or eax, '0' //Convert digit to ASCII - mov [edi], al //Store digit out to memory - //Calculate digit #5 - lea eax, [edx*4+edx] //5*fraction, new digit eax<31:25> - lea edx, [edx*4+edx] //5*fraction, new fraction edx<24:0> - cmp ecx, 1 //Any non-zero digit yet ? - sbb edi, -1 //Yes->increment ptr, No->keep old ptr - shr eax, 25 //Next digit - and edx, $01ffffff //Fraction part - or ecx, eax //Accumulate next digit - or eax, '0' //Convert digit to ASCII - mov [edi], al //Store digit out to memory - //Calculate digit #6 - lea eax, [edx*4+edx] //5*fraction, new digit eax<31:24> - lea edx, [edx*4+edx] //5*fraction, new fraction edx<23:0> - cmp ecx, 1 //Any non-zero digit yet ? - sbb edi, -1 //Yes->increment ptr, No->keep old ptr - shr eax, 24 //Next digit - and edx, $00ffffff //Fraction part - or ecx, eax //Accumulate next digit - or eax, '0' //Convert digit to ASCII - mov [edi], al //Store digit out to memory - //Calculate digit #7 - lea eax, [edx*4+edx] //5*fraction, new digit eax<31:23> - lea edx, [edx*4+edx] //5*fraction, new fraction edx<31:23> - cmp ecx, 1 //Any non-zero digit yet ? - sbb edi, -1 //Yes->increment ptr, No->keep old ptr - shr eax, 23 //Next digit - and edx, $007fffff //Fraction part - or ecx, eax //Accumulate next digit - or eax, '0' //Convert digit to ASCII - mov [edi], al //Store digit out to memory - //Calculate digit #8 - lea eax, [edx*4+edx] //5*fraction, new digit eax<31:22> - lea edx, [edx*4+edx] //5*fraction, new fraction edx<22:0> - cmp ecx, 1 //Any non-zero digit yet ? - sbb edi, -1 //Yes->increment ptr, No->keep old ptr - shr eax, 22 //Next digit - and edx, $003fffff //Fraction part - or ecx, eax //Accumulate next digit - or eax, '0' //Convert digit to ASCII - mov [edi], al //Store digit out to memory - //Calculate digit #9 - lea eax, [edx*4+edx] //5*fraction, new digit eax<31:21> - lea edx, [edx*4+edx] //5*fraction, new fraction edx<21:0> - cmp ecx, 1 //Any non-zero digit yet ? - sbb edi, -1 //Yes->increment ptr, No->keep old ptr - shr eax, 21 //Next digit - and edx, $001fffff //Fraction part - or ecx, eax //Accumulate next digit - or eax, '0' //Convert digit to ASCII - mov [edi], al //Store digit out to memory - //Calculate digit #10 - lea eax, [edx*4+edx] //5*fraction, new digit eax<31:20> - cmp ecx, 1 //Any-non-zero digit yet ? - sbb edi, -1 //Yes->increment ptr, No->keep old ptr - shr eax, 20 //Next digit - or eax, '0' //Convert digit to ASCII - mov [edi], al //Store last digit and end marker out to memory + mov edi, edx //Pointer to the first character in edi + {Calculate leading digit: divide the number by 1e9} + add eax, 1 //Increment the number + mov edx, $89705F41 //1e9 reciprocal + mul edx //Multplying with reciprocal + shr eax, 30 //Save fraction bits + mov ecx, edx //First digit in bits <31:29> + and edx, $1FFFFFFF //Filter fraction part edx<28:0> + shr ecx, 29 //Get leading digit into accumulator + lea edx, [edx + 4 * edx] //Calculate ... + add edx, eax //... 5*fraction + mov eax, ecx //Copy leading digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #2} + mov eax, edx //Point format such that 1.0 = 2^28 + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 28 //Next digit + and edx, $0fffffff //Fraction part edx<27:0> + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #3} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:27> + lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<26:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 27 //Next digit + and edx, $07ffffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #4} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:26> + lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<25:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 26 //Next digit + and edx, $03ffffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #5} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:25> + lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<24:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 25 //Next digit + and edx, $01ffffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #6} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:24> + lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<23:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 24 //Next digit + and edx, $00ffffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #7} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:23> + lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<31:23> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 23 //Next digit + and edx, $007fffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #8} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:22> + lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<22:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 22 //Next digit + and edx, $003fffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #9} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:21> + lea edx, [edx * 4 + edx] //5*fraction, new fraction edx<21:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 21 //Next digit + and edx, $001fffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + {Calculate digit #10} + lea eax, [edx * 4 + edx] //5*fraction, new digit eax<31:20> + cmp ecx, 1 //Any-non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 20 //Next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store last digit and end marker out to memory {Return a pointer to the next character} lea eax, [edi + 1] {Restore edi} - pop edi + pop edi end; +{$endif} -{Converts a cardinal to a hexadecimal string at the buffer location, returning - the new buffer position.} -function CardinalToHexBuf(ACardinal: integer; ABuffer: PAnsiChar): PAnsiChar; +{Converts an unsigned integer to a hexadecimal string at the buffer location, + returning the new buffer position.} +function NativeUIntToHexBuf(ANum: NativeUInt; APBuffer: PAnsiChar): PAnsiChar; +{$ifndef Use32BitAsm} +const + MaxDigits = 16; +var + LDigitBuffer: array[0..MaxDigits - 1] of AnsiChar; + LCount: Cardinal; + LDigit: NativeUInt; +begin + {Generate the digits in the local buffer} + LCount := 0; + repeat + LDigit := ANum; + ANum := ANum div 16; + LDigit := LDigit - ANum * 16; + Inc(LCount); + LDigitBuffer[MaxDigits - LCount] := HexTable[LDigit]; + until ANum = 0; + {Copy the digits to the output buffer and advance it} + System.Move(LDigitBuffer[MaxDigits - LCount], APBuffer^, LCount); + Result := APBuffer + LCount; +end; +{$else} asm {On entry: - eax = ACardinal + eax = ANum edx = ABuffer} push ebx push edi - {Save ACardinal in ebx} + {Save ANum in ebx} mov ebx, eax {Get a pointer to the first character in edi} mov edi, edx @@ -2464,13 +3090,14 @@ function CardinalToHexBuf(ACardinal: integer; ABuffer: PAnsiChar): PAnsiChar; pop edi pop ebx end; +{$endif} {Appends the source text to the destination and returns the new destination position} function AppendStringToBuffer(const ASource, ADestination: PAnsiChar; ACount: Cardinal): PAnsiChar; begin System.Move(ASource^, ADestination^, ACount); - Result := Pointer(Cardinal(ADestination) + ACount); + Result := Pointer(PByte(ADestination) + ACount); end; {Appends the name of the class to the destination buffer and returns the new @@ -2482,7 +3109,7 @@ function AppendClassNameToBuffer(AClass: TClass; ADestination: PAnsiChar): PAnsi {Get a pointer to the class name} if AClass <> nil then begin - LPClassName := PShortString(PPointer(Integer(AClass) + vmtClassName)^); + LPClassName := PShortString(PPointer(PByte(AClass) + vmtClassName)^); {Append the class name} Result := AppendStringToBuffer(@LPClassName^[1], ADestination, Length(LPClassName^)); end @@ -2505,21 +3132,21 @@ procedure ShowMessageBox(AText, ACaption: PAnsiChar); end; {Returns the class for a memory block. Returns nil if it is not a valid class} -function GetObjectClass(APointer: Pointer): TClass; +function DetectClassInstance(APointer: Pointer): TClass; {$ifndef Linux} var LMemInfo: TMemoryBasicInformation; {Checks whether the given address is a valid address for a VMT entry.} - function IsValidVMTAddress(APAddress: PCardinal): Boolean; + function IsValidVMTAddress(APAddress: Pointer): Boolean; begin {Do some basic pointer checks: Must be dword aligned and beyond 64K} - if (Cardinal(APAddress) > 65535) - and (Cardinal(APAddress) and 3 = 0) then + if (UIntPtr(APAddress) > 65535) + and (UIntPtr(APAddress) and 3 = 0) then begin {Do we need to recheck the virtual memory?} - if (Cardinal(LMemInfo.BaseAddress) > Cardinal(APAddress)) - or ((Cardinal(LMemInfo.BaseAddress) + LMemInfo.RegionSize) < (Cardinal(APAddress) + 4)) then + if (UIntPtr(LMemInfo.BaseAddress) > UIntPtr(APAddress)) + or ((UIntPtr(LMemInfo.BaseAddress) + LMemInfo.RegionSize) < (UIntPtr(APAddress) + 4)) then begin {Get the VM status for the pointer} LMemInfo.RegionSize := 0; @@ -2538,21 +3165,21 @@ function GetObjectClass(APointer: Pointer): TClass; {Returns true if AClassPointer points to a class VMT} function InternalIsValidClass(AClassPointer: Pointer; ADepth: Integer = 0): Boolean; var - LParentClassSelfPointer: PCardinal; + LParentClassSelfPointer: PPointer; begin {Check that the self pointer as well as parent class self pointer addresses are valid} if (ADepth < 1000) - and IsValidVMTAddress(Pointer(Integer(AClassPointer) + vmtSelfPtr)) - and IsValidVMTAddress(Pointer(Integer(AClassPointer) + vmtParent)) then + and IsValidVMTAddress(Pointer(PByte(AClassPointer) + vmtSelfPtr)) + and IsValidVMTAddress(Pointer(PByte(AClassPointer) + vmtParent)) then begin {Get a pointer to the parent class' self pointer} - LParentClassSelfPointer := PPointer(Integer(AClassPointer) + vmtParent)^; + LParentClassSelfPointer := PPointer(PByte(AClassPointer) + vmtParent)^; {Check that the self pointer as well as the parent class is valid} - Result := (PPointer(Integer(AClassPointer) + vmtSelfPtr)^ = AClassPointer) + Result := (PPointer(PByte(AClassPointer) + vmtSelfPtr)^ = AClassPointer) and ((LParentClassSelfPointer = nil) or (IsValidVMTAddress(LParentClassSelfPointer) - and InternalIsValidClass(PCardinal(LParentClassSelfPointer^), ADepth + 1))); + and InternalIsValidClass(LParentClassSelfPointer^, ADepth + 1))); end else Result := False; @@ -2560,7 +3187,7 @@ function GetObjectClass(APointer: Pointer): TClass; begin {Get the class pointer from the (suspected) object} - Result := TClass(PCardinal(APointer)^); + Result := TClass(PPointer(APointer)^); {No VM info yet} LMemInfo.RegionSize := 0; {Check the block} @@ -2579,12 +3206,12 @@ function GetObjectClass(APointer: Pointer): TClass; {$endif} {Gets the available size inside a block} -function GetAvailableSpaceInBlock(APointer: Pointer): Cardinal; +function GetAvailableSpaceInBlock(APointer: Pointer): NativeUInt; var - LBlockHeader: Cardinal; + LBlockHeader: NativeUInt; LPSmallBlockPool: PSmallBlockPoolHeader; begin - LBlockHeader := PCardinal(Cardinal(APointer) - 4)^; + LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^; if LBlockHeader and (IsMediumBlockFlag or IsLargeBlockFlag) = 0 then begin LPSmallBlockPool := PSmallBlockPoolHeader(LBlockHeader and DropSmallFlagsMask); @@ -2614,7 +3241,11 @@ procedure LockAllSmallBlockTypes; begin while LockCmpxchg(0, 1, @SmallBlockTypes[LInd].BlockTypeLocked) <> 0 do begin -{$ifndef NeverSleepOnThreadContention} +{$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThread; + {$endif} +{$else} Sleep(InitialSleepTime); if LockCmpxchg(0, 1, @SmallBlockTypes[LInd].BlockTypeLocked) = 0 then Break; @@ -2629,22 +3260,22 @@ procedure LockAllSmallBlockTypes; procedure GetFirstAndLastSmallBlockInPool(APSmallBlockPool: PSmallBlockPoolHeader; var AFirstPtr, ALastPtr: Pointer); var - LBlockSize: Cardinal; + LBlockSize: NativeUInt; begin {Get the pointer to the first block} - AFirstPtr := Pointer(Cardinal(APSmallBlockPool) + SmallBlockPoolHeaderSize); + AFirstPtr := Pointer(PByte(APSmallBlockPool) + SmallBlockPoolHeaderSize); {Get a pointer to the last block} if (APSmallBlockPool.BlockType.CurrentSequentialFeedPool <> APSmallBlockPool) - or (Cardinal(APSmallBlockPool.BlockType.NextSequentialFeedBlockAddress) > Cardinal(APSmallBlockPool.BlockType.MaxSequentialFeedBlockAddress)) then + or (UIntPtr(APSmallBlockPool.BlockType.NextSequentialFeedBlockAddress) > UIntPtr(APSmallBlockPool.BlockType.MaxSequentialFeedBlockAddress)) then begin {Not the sequential feed - point to the end of the block} - LBlockSize := PCardinal(Cardinal(APSmallBlockPool) - 4)^ and DropMediumAndLargeFlagsMask; - ALastPtr := Pointer(Cardinal(APSmallBlockPool) + LBlockSize - APSmallBlockPool.BlockType.BlockSize); + LBlockSize := PNativeUInt(PByte(APSmallBlockPool) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask; + ALastPtr := Pointer(PByte(APSmallBlockPool) + LBlockSize - APSmallBlockPool.BlockType.BlockSize); end else begin {The sequential feed pool - point to before the next sequential feed block} - ALastPtr := Pointer(Cardinal(APSmallBlockPool.BlockType.NextSequentialFeedBlockAddress) - 1); + ALastPtr := Pointer(PByte(APSmallBlockPool.BlockType.NextSequentialFeedBlockAddress) - 1); end; end; @@ -2654,14 +3285,14 @@ procedure GetFirstAndLastSmallBlockInPool(APSmallBlockPool: PSmallBlockPoolHeade pool has been reached} function NextMediumBlock(APMediumBlock: Pointer): Pointer; var - LBlockSize: Cardinal; + LBlockSize: NativeUInt; begin {Get the size of this block} - LBlockSize := PCardinal(Cardinal(APMediumBlock) - 4)^ and DropMediumAndLargeFlagsMask; + LBlockSize := PNativeUInt(PByte(APMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask; {Advance the pointer} - Result := Pointer(Cardinal(APMediumBlock) + LBlockSize); + Result := Pointer(PByte(APMediumBlock) + LBlockSize); {Is the next block the end of medium pool marker?} - LBlockSize := PCardinal(Cardinal(Result) - 4)^ and DropMediumAndLargeFlagsMask; + LBlockSize := PNativeUInt(PByte(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask; if LBlockSize = 0 then Result := nil; end; @@ -2670,10 +3301,10 @@ function NextMediumBlock(APMediumBlock: Pointer): Pointer; function GetFirstMediumBlockInPool(APMediumBlockPoolHeader: PMediumBlockPoolHeader): Pointer; begin if (MediumSequentialFeedBytesLeft = 0) - or (Cardinal(LastSequentiallyFedMediumBlock) < Cardinal(APMediumBlockPoolHeader)) - or (Cardinal(LastSequentiallyFedMediumBlock) > Cardinal(APMediumBlockPoolHeader) + MediumBlockPoolSize) then + or (UIntPtr(LastSequentiallyFedMediumBlock) < UIntPtr(APMediumBlockPoolHeader)) + or (UIntPtr(LastSequentiallyFedMediumBlock) > UIntPtr(APMediumBlockPoolHeader) + MediumBlockPoolSize) then begin - Result := Pointer(Cardinal(APMediumBlockPoolHeader) + MediumBlockPoolHeaderSize); + Result := Pointer(PByte(APMediumBlockPoolHeader) + MediumBlockPoolHeaderSize); end else begin @@ -2685,9 +3316,9 @@ function GetFirstMediumBlockInPool(APMediumBlockPoolHeader: PMediumBlockPoolHead end; end; -{Locks the medium blocks. Note that if AsmVersion is defined that the routine - is assumed to preserve all registers except eax.} -{$ifndef AsmVersion} +{Locks the medium blocks. Note that the 32-bit asm version is assumed to + preserve all registers except eax.} +{$ifndef Use32BitAsm} procedure LockMediumBlocks; begin {Lock the medium blocks} @@ -2697,7 +3328,11 @@ procedure LockMediumBlocks; begin while LockCmpxchg(0, 1, @MediumBlocksLocked) <> 0 do begin -{$ifndef NeverSleepOnThreadContention} +{$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThread; + {$endif} +{$else} Sleep(InitialSleepTime); if LockCmpxchg(0, 1, @MediumBlocksLocked) = 0 then Break; @@ -2715,7 +3350,19 @@ procedure LockMediumBlocks; {Attempt to lock the medium blocks} lock cmpxchg MediumBlocksLocked, ah je @Done -{$ifndef NeverSleepOnThreadContention} +{$ifdef NeverSleepOnThreadContention} + {Pause instruction (improves performance on P4)} + rep nop + {$ifdef UseSwitchToThread} + push ecx + push edx + call SwitchToThread + pop edx + pop ecx + {$endif} + {Try again} + jmp @MediumBlockLockLoop +{$else} {Couldn't lock the medium blocks - sleep and try again} push ecx push edx @@ -2737,21 +3384,16 @@ procedure LockMediumBlocks; pop ecx {Try again} jmp @MediumBlockLockLoop -{$else} - {Pause instruction (improves performance on P4)} - rep nop - {Try again} - jmp @MediumBlockLockLoop {$endif} @Done: end; {$endif} -{$ifndef AsmVersion} {Removes a medium block from the circular linked list of free blocks. Does not change any header flags. Medium blocks should be locked before calling this procedure.} procedure RemoveMediumFreeBlock(APMediumFreeBlock: PMediumFreeBlock); +{$ifndef ASMVersion} var LPreviousFreeBlock, LNextFreeBlock: PMediumFreeBlock; LBinNumber, LBinGroupNumber: Cardinal; @@ -2767,7 +3409,7 @@ procedure RemoveMediumFreeBlock(APMediumFreeBlock: PMediumFreeBlock); if LPreviousFreeBlock = LNextFreeBlock then begin {Get the bin number for this block size} - LBinNumber := (Cardinal(LNextFreeBlock) - Cardinal(@MediumBlockBins)) div SizeOf(TMediumFreeBlock); + LBinNumber := (UIntPtr(LNextFreeBlock) - UIntPtr(@MediumBlockBins)) div SizeOf(TMediumFreeBlock); LBinGroupNumber := LBinNumber div 32; {Flag this bin as empty} MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber] @@ -2782,10 +3424,7 @@ procedure RemoveMediumFreeBlock(APMediumFreeBlock: PMediumFreeBlock); end; end; {$else} -{Removes a medium block from the circular linked list of free blocks. - Does not change any header flags. Medium blocks should be locked - before calling this procedure.} -procedure RemoveMediumFreeBlock(APMediumFreeBlock: PMediumFreeBlock); +{$ifdef 32Bit} asm {On entry: eax = APMediumFreeBlock} {Get the current previous and next blocks} @@ -2822,11 +3461,48 @@ procedure RemoveMediumFreeBlock(APMediumFreeBlock: PMediumFreeBlock); rol eax, cl and MediumBlockBinGroupBitmap, eax end; +{$else} +asm + {On entry: rcx = APMediumFreeBlock} + mov rax, rcx + {Get the current previous and next blocks} + mov rcx, TMediumFreeBlock[rax].NextFreeBlock + mov rdx, TMediumFreeBlock[rax].PreviousFreeBlock + {Is this bin now empty? If the previous and next free block pointers are + equal, they must point to the bin.} + cmp rcx, rdx + {Remove this block from the linked list} + mov TMediumFreeBlock[rcx].PreviousFreeBlock, rdx + mov TMediumFreeBlock[rdx].NextFreeBlock, rcx + {Is this bin now empty? If the previous and next free block pointers are + equal, they must point to the bin.} + jne @Done + {Get the bin number for this block size in rcx} + lea r8, MediumBlockBins + sub rcx, r8 + mov edx, ecx + shr ecx, 4 + {Get the group number in edx} + shr edx, 9 + {Flag this bin as empty} + mov eax, -2 + rol eax, cl + lea r8, MediumBlockBinBitmaps + and dword ptr [r8 + rdx * 4], eax + jnz @Done + {Flag this group as empty} + mov eax, -2 + mov ecx, edx + rol eax, cl + and MediumBlockBinGroupBitmap, eax +@Done: +end; +{$endif} {$endif} -{$ifndef AsmVersion} {Inserts a medium block into the appropriate medium block bin.} procedure InsertMediumBlockIntoBin(APMediumFreeBlock: PMediumFreeBlock; AMediumBlockSize: Cardinal); +{$ifndef ASMVersion} var LBinNumber, LBinGroupNumber: Cardinal; LPBin, LPFirstFreeBlock: PMediumFreeBlock; @@ -2858,8 +3534,7 @@ procedure InsertMediumBlockIntoBin(APMediumFreeBlock: PMediumFreeBlock; AMediumB end; end; {$else} -{Inserts a medium block into the appropriate medium block bin.} -procedure InsertMediumBlockIntoBin(APMediumFreeBlock: PMediumFreeBlock; AMediumBlockSize: Cardinal); +{$ifdef 32Bit} asm {On entry: eax = APMediumFreeBlock, edx = AMediumBlockSize} {Get the bin number for this block size. Get the bin that holds blocks of at @@ -2904,14 +3579,60 @@ procedure InsertMediumBlockIntoBin(APMediumFreeBlock: PMediumFreeBlock; AMediumB shl eax, cl or MediumBlockBinGroupBitmap, eax end; +{$else} +asm + {On entry: rax = APMediumFreeBlock, edx = AMediumBlockSize} + mov rax, rcx + {Get the bin number for this block size. Get the bin that holds blocks of at + least this size.} + sub edx, MinimumMediumBlockSize + shr edx, 8 + {Validate the bin number} + sub edx, MediumBlockBinCount - 1 + sbb ecx, ecx + and edx, ecx + add edx, MediumBlockBinCount - 1 + mov r9, rdx + {Get the bin address in rcx} + lea rcx, MediumBlockBins + shl edx, 4 + add rcx, rdx + {Bins are LIFO, se we insert this block as the first free block in the bin} + mov rdx, TMediumFreeBlock[rcx].NextFreeBlock + {Was this bin empty?} + cmp rdx, rcx + mov TMediumFreeBlock[rax].PreviousFreeBlock, rcx + mov TMediumFreeBlock[rax].NextFreeBlock, rdx + mov TMediumFreeBlock[rdx].PreviousFreeBlock, rax + mov TMediumFreeBlock[rcx].NextFreeBlock, rax + {Was this bin empty?} + jne @Done + {Get the bin number in ecx} + mov rcx, r9 + {Get the group number in edx} + mov rdx, r9 + shr edx, 5 + {Flag this bin as not empty} + mov eax, 1 + shl eax, cl + lea r8, MediumBlockBinBitmaps + or dword ptr [r8 + rdx * 4], eax + {Flag the group as not empty} + mov eax, 1 + mov ecx, edx + shl eax, cl + or MediumBlockBinGroupBitmap, eax +@Done: +end; +{$endif} {$endif} -{$ifndef AsmVersion} {Bins what remains in the current sequential feed medium block pool. Medium blocks must be locked.} procedure BinMediumSequentialFeedRemainder; +{$ifndef ASMVersion} var - LSequentialFeedFreeSize, LNextBlockSizeAndFlags: Cardinal; + LSequentialFeedFreeSize, LNextBlockSizeAndFlags: NativeUInt; LPRemainderBlock, LNextMediumBlock: Pointer; begin LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft; @@ -2919,9 +3640,9 @@ procedure BinMediumSequentialFeedRemainder; begin {Get the block after the open space} LNextMediumBlock := LastSequentiallyFedMediumBlock; - LNextBlockSizeAndFlags := PCardinal(Cardinal(LNextMediumBlock) - BlockHeaderSize)^; + LNextBlockSizeAndFlags := PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^; {Point to the remainder} - LPRemainderBlock := Pointer(Cardinal(LNextMediumBlock) - LSequentialFeedFreeSize); + LPRemainderBlock := Pointer(PByte(LNextMediumBlock) - LSequentialFeedFreeSize); {$ifndef FullDebugMode} {Can the next block be combined with the remainder?} if (LNextBlockSizeAndFlags and IsFreeBlockFlag) <> 0 then @@ -2936,24 +3657,24 @@ procedure BinMediumSequentialFeedRemainder; begin {$endif} {Set the "previous block is free" flag of the next block} - PCardinal(Cardinal(LNextMediumBlock) - BlockHeaderSize)^ := LNextBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag; + PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^ := LNextBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag; {$ifndef FullDebugMode} end; {$endif} {Store the size of the block as well as the flags} - PCardinal(Cardinal(LPRemainderBlock) - BlockHeaderSize)^ := LSequentialFeedFreeSize or IsMediumBlockFlag or IsFreeBlockFlag; + PNativeUInt(PByte(LPRemainderBlock) - BlockHeaderSize)^ := LSequentialFeedFreeSize or IsMediumBlockFlag or IsFreeBlockFlag; {Store the trailing size marker} - PCardinal(Cardinal(LPRemainderBlock) + LSequentialFeedFreeSize - 8)^ := LSequentialFeedFreeSize; + PNativeUInt(PByte(LPRemainderBlock) + LSequentialFeedFreeSize - BlockHeaderSize * 2)^ := LSequentialFeedFreeSize; {$ifdef FullDebugMode} {In full debug mode the sequential feed remainder will never be too small to fit a full debug header.} {Clear the user area of the block} - FillDWord(Pointer(Cardinal(LPRemainderBlock) + SizeOf(TFullDebugBlockHeader) + 4)^, - LSequentialFeedFreeSize - FullDebugBlockOverhead - 4, - {$ifndef CatchUseOfFreedInterfaces}DebugFillDWord{$else}Cardinal(@VMTBadInterface){$endif}); + DebugFillMem(Pointer(PByte(LPRemainderBlock) + SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt))^, + LSequentialFeedFreeSize - FullDebugBlockOverhead - SizeOf(NativeUInt), + {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif}); {We need to set a valid debug header and footer in the remainder} - PFullDebugBlockHeader(LPRemainderBlock).HeaderCheckSum := Cardinal(LPRemainderBlock); - PCardinal(Cardinal(LPRemainderBlock) + SizeOf(TFullDebugBlockHeader))^ := not Cardinal(LPRemainderBlock); + PFullDebugBlockHeader(LPRemainderBlock).HeaderCheckSum := NativeUInt(LPRemainderBlock); + PNativeUInt(PByte(LPRemainderBlock) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(LPRemainderBlock); {$endif} {Bin this medium block} if LSequentialFeedFreeSize >= MinimumMediumBlockSize then @@ -2961,9 +3682,7 @@ procedure BinMediumSequentialFeedRemainder; end; end; {$else} -{Bins what remains in the current sequential feed medium block pool. Medium - blocks must be locked.} -procedure BinMediumSequentialFeedRemainder; +{$ifdef 32Bit} asm cmp MediumSequentialFeedBytesLeft, 0 jne @MustBinMedium @@ -3019,8 +3738,64 @@ procedure BinMediumSequentialFeedRemainder; {edx = total size of the remainder} add edx, ecx jmp @BinTheRemainder +@Done: +end; +{$else} +asm + .params 2 + xor eax, eax + cmp MediumSequentialFeedBytesLeft, eax + je @Done + {Get a pointer to the last sequentially allocated medium block} + mov rax, LastSequentiallyFedMediumBlock + {Is the block that was last fed sequentially free?} + test byte ptr [rax - BlockHeaderSize], IsFreeBlockFlag + jnz @LastBlockFedIsFree + {Set the "previous block is free" flag in the last block fed} + or qword ptr [rax - BlockHeaderSize], PreviousMediumBlockIsFreeFlag + {Get the remainder in edx} + mov edx, MediumSequentialFeedBytesLeft + {Point eax to the start of the remainder} + sub rax, rdx +@BinTheRemainder: + {Status: rax = start of remainder, edx = size of remainder} + {Store the size of the block as well as the flags} + lea rcx, [rdx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [rax - BlockHeaderSize], rcx + {Store the trailing size marker} + mov [rax + rdx - 2 * BlockHeaderSize], rdx + {Bin this medium block} + cmp edx, MinimumMediumBlockSize + jb @Done + mov rcx, rax + call InsertMediumBlockIntoBin + jmp @Done +@LastBlockFedIsFree: + {Drop the flags} + mov rdx, DropMediumAndLargeFlagsMask + and rdx, [rax - BlockHeaderSize] + {Free the last block fed} + cmp edx, MinimumMediumBlockSize + jb @DontRemoveLastFed + {Last fed block is free - remove it from its size bin} + mov rcx, rax + call RemoveMediumFreeBlock + {Re-read rax and rdx} + mov rax, LastSequentiallyFedMediumBlock + mov rdx, DropMediumAndLargeFlagsMask + and rdx, [rax - BlockHeaderSize] +@DontRemoveLastFed: + {Get the number of bytes left in ecx} + mov ecx, MediumSequentialFeedBytesLeft + {Point rax to the start of the remainder} + sub rax, rcx + {edx = total size of the remainder} + add edx, ecx + jmp @BinTheRemainder +@Done: end; {$endif} +{$endif} {Allocates a new sequential feed medium block pool and immediately splits off a block of the requested size. The block size must be a multiple of 16 and @@ -3044,14 +3819,14 @@ function AllocNewSequentialFeedMediumPool(AFirstBlockSize: Cardinal): Pointer; PMediumBlockPoolHeader(LNewPool).NextMediumBlockPoolHeader := LOldFirstMediumBlockPool; LOldFirstMediumBlockPool.PreviousMediumBlockPoolHeader := LNewPool; {Store the sequential feed pool trailer} - PCardinal(Cardinal(LNewPool) + MediumBlockPoolSize - BlockHeaderSize)^ := IsMediumBlockFlag; + PNativeUInt(PByte(LNewPool) + MediumBlockPoolSize - BlockHeaderSize)^ := IsMediumBlockFlag; {Get the number of bytes still available} MediumSequentialFeedBytesLeft := (MediumBlockPoolSize - MediumBlockPoolHeaderSize) - AFirstBlockSize; {Get the result} - Result := Pointer(Cardinal(LNewPool) + MediumBlockPoolSize - AFirstBlockSize); + Result := Pointer(PByte(LNewPool) + MediumBlockPoolSize - AFirstBlockSize); LastSequentiallyFedMediumBlock := Result; {Store the block header} - PCardinal(Cardinal(Result) - BlockHeaderSize)^ := AFirstBlockSize or IsMediumBlockFlag; + PNativeUInt(PByte(Result) - BlockHeaderSize)^ := AFirstBlockSize or IsMediumBlockFlag; end else begin @@ -3061,20 +3836,6 @@ function AllocNewSequentialFeedMediumPool(AFirstBlockSize: Cardinal): Pointer; end; end; -{Frees a medium block pool. Medium blocks must be locked on entry.} -procedure FreeMediumBlockPool(AMediumBlockPool: PMediumBlockPoolHeader); -var - LPPreviousMediumBlockPoolHeader, LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader; -begin - {Remove this medium block pool from the linked list} - LPPreviousMediumBlockPoolHeader := AMediumBlockPool.PreviousMediumBlockPoolHeader; - LPNextMediumBlockPoolHeader := AMediumBlockPool.NextMediumBlockPoolHeader; - LPPreviousMediumBlockPoolHeader.NextMediumBlockPoolHeader := LPNextMediumBlockPoolHeader; - LPNextMediumBlockPoolHeader.PreviousMediumBlockPoolHeader := LPPreviousMediumBlockPoolHeader; - {Free the medium block pool} - VirtualFree(AMediumBlockPool, 0, MEM_RELEASE); -end; - {-----------------Large Block Management------------------} {Locks the large blocks} @@ -3087,7 +3848,11 @@ procedure LockLargeBlocks; begin while LockCmpxchg(0, 1, @LargeBlocksLocked) <> 0 do begin -{$ifndef NeverSleepOnThreadContention} +{$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThread; + {$endif} +{$else} Sleep(InitialSleepTime); if LockCmpxchg(0, 1, @LargeBlocksLocked) = 0 then Break; @@ -3101,14 +3866,15 @@ procedure LockLargeBlocks; allow for alignment etc.). ASize must be the actual user requested size. This procedure will pad it to the appropriate page boundary and also add the space required by the header.} -function AllocateLargeBlock(ASize: Cardinal): Pointer; +function AllocateLargeBlock(ASize: NativeUInt): Pointer; var - LLargeUsedBlockSize: Cardinal; + LLargeUsedBlockSize: NativeUInt; LOldFirstLargeBlock: PLargeBlockHeader; begin {Pad the block size to include the header and granularity. We also add a - 4-byte overhead so a huge block size is a multiple of 16 bytes less 4 (so we - can use a single move function for reallocating all block types)} + SizeOf(Pointer) overhead so a huge block size is a multiple of 16 bytes less + SizeOf(Pointer) (so we can use a single move function for reallocating all + block types)} LLargeUsedBlockSize := (ASize + LargeBlockHeaderSize + LargeBlockGranularity - 1 + BlockHeaderSize) and -LargeBlockGranularity; {Get the Large block} @@ -3129,15 +3895,12 @@ function AllocateLargeBlock(ASize: Cardinal): Pointer; LOldFirstLargeBlock.PreviousLargeBlockHeader := Result; LargeBlocksLocked := False; {Add the size of the header} - Inc(Cardinal(Result), LargeBlockHeaderSize); + Inc(PByte(Result), LargeBlockHeaderSize); {$ifdef FullDebugMode} - {Clear the user area of the block} - FillDWord(Pointer(Cardinal(Result) + SizeOf(TFullDebugBlockHeader) + 4)^, - LLargeUsedBlockSize - LargeBlockHeaderSize - FullDebugBlockOverhead - 4, - {$ifndef CatchUseOfFreedInterfaces}DebugFillDWord{$else}Cardinal(@VMTBadInterface){$endif}); - {Set the debug header and footer} - PFullDebugBlockHeader(Result).HeaderCheckSum := Cardinal(Result); - PCardinal(Cardinal(Result) + SizeOf(TFullDebugBlockHeader))^ := not Cardinal(Result); + {Since large blocks are never reused, the user area is not initialized to + the debug fill pattern, but the debug header and footer must be set.} + PFullDebugBlockHeader(Result).HeaderCheckSum := NativeUInt(Result); + PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(Result); {$endif} end; end; @@ -3147,13 +3910,18 @@ function FreeLargeBlock(APointer: Pointer): Integer; var LPreviousLargeBlockHeader, LNextLargeBlockHeader: PLargeBlockHeader; {$ifndef Linux} - LRemainingSize: Cardinal; + LRemainingSize: NativeUInt; LCurrentSegment: Pointer; LMemInfo: TMemoryBasicInformation; {$endif} begin +{$ifdef ClearLargeBlocksBeforeReturningToOS} + FillChar(APointer^, + (PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).BlockSizeAndFlags + and DropMediumAndLargeFlagsMask) - LargeBlockHeaderSize, 0); +{$endif} {Point to the start of the large block} - APointer := Pointer(Cardinal(APointer) - LargeBlockHeaderSize); + APointer := Pointer(PByte(APointer) - LargeBlockHeaderSize); {Get the previous and next large blocks} LockLargeBlocks; LPreviousLargeBlockHeader := PLargeBlockHeader(APointer).PreviousLargeBlockHeader; @@ -3187,11 +3955,11 @@ function FreeLargeBlock(APointer: Pointer): Integer; Break; end; {Done?} - if LMemInfo.RegionSize >= LRemainingSize then + if NativeUInt(LMemInfo.RegionSize) >= LRemainingSize then Break; {Decrement the remaining size} - Dec(LRemainingSize, LMemInfo.RegionSize); - Inc(Cardinal(LCurrentSegment), LMemInfo.RegionSize); + Dec(LRemainingSize, NativeUInt(LMemInfo.RegionSize)); + Inc(PByte(LCurrentSegment), NativeUInt(LMemInfo.RegionSize)); end; end; {$endif} @@ -3209,45 +3977,44 @@ function FreeLargeBlock(APointer: Pointer): Integer; {$ifndef FullDebugMode} {Reallocates a large block to at least the requested size. Returns the new pointer, or nil on error} -function ReallocateLargeBlock(APointer: Pointer; ANewSize: Cardinal): Pointer; +function ReallocateLargeBlock(APointer: Pointer; ANewSize: NativeUInt): Pointer; var LOldAvailableSize, LBlockHeader, LOldUserSize, LMinimumUpsize, - LNewAllocSize: Cardinal; + LNewAllocSize: NativeUInt; {$ifndef Linux} - LNewSegmentSize: Cardinal; + LNewSegmentSize: NativeUInt; LNextSegmentPointer: Pointer; LMemInfo: TMemoryBasicInformation; {$endif} begin {Get the block header} - LBlockHeader := PCardinal(Cardinal(APointer) - BlockHeaderSize)^; + LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^; {Large block - size is (16 + 4) less than the allocated size} LOldAvailableSize := (LBlockHeader and DropMediumAndLargeFlagsMask) - (LargeBlockHeaderSize + BlockHeaderSize); {Is it an upsize or a downsize?} - if Cardinal(ANewSize) > LOldAvailableSize then + if ANewSize > LOldAvailableSize then begin {This pointer is being reallocated to a larger block and therefore it is logical to assume that it may be enlarged again. Since reallocations are expensive, there is a minimum upsize percentage to avoid unnecessary future move operations.} {Add 25% for large block upsizes} - LMinimumUpsize := Cardinal(LOldAvailableSize) - + (Cardinal(LOldAvailableSize) shr 2); - if Cardinal(ANewSize) < LMinimumUpsize then + LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2); + if ANewSize < LMinimumUpsize then LNewAllocSize := LMinimumUpsize else LNewAllocSize := ANewSize; {$ifndef Linux} {Can another large block segment be allocated directly after this segment, thus negating the need to move the data?} - LNextSegmentPointer := Pointer(Cardinal(APointer) - LargeBlockHeaderSize + (LBlockHeader and DropMediumAndLargeFlagsMask)); + LNextSegmentPointer := Pointer(PByte(APointer) - LargeBlockHeaderSize + (LBlockHeader and DropMediumAndLargeFlagsMask)); VirtualQuery(LNextSegmentPointer, LMemInfo, SizeOf(LMemInfo)); - if (LMemInfo.State = MEM_FREE) then + if LMemInfo.State = MEM_FREE then begin {Round the region size to the previous 64K} LMemInfo.RegionSize := LMemInfo.RegionSize and -LargeBlockGranularity; {Enough space to grow in place?} - if (LMemInfo.RegionSize > (ANewSize - LOldAvailableSize)) then + if NativeUInt(LMemInfo.RegionSize) > (ANewSize - LOldAvailableSize) then begin {There is enough space after the block to extend it - determine by how much} @@ -3260,9 +4027,9 @@ function ReallocateLargeBlock(APointer: Pointer; ANewSize: Cardinal): Pointer; and (VirtualAlloc(LNextSegmentPointer, LNewSegmentSize, MEM_COMMIT, PAGE_READWRITE) <> nil) then begin {Update the requested size} - PLargeBlockHeader(Cardinal(APointer) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize; - PLargeBlockHeader(Cardinal(APointer) - LargeBlockHeaderSize).BlockSizeAndFlags := - (PLargeBlockHeader(Cardinal(APointer) - LargeBlockHeaderSize).BlockSizeAndFlags + LNewSegmentSize) + PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize; + PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).BlockSizeAndFlags := + (PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).BlockSizeAndFlags + LNewSegmentSize) or LargeBlockIsSegmented; {Success} Result := APointer; @@ -3279,12 +4046,12 @@ function ReallocateLargeBlock(APointer: Pointer; ANewSize: Cardinal): Pointer; not be if the block that is being reallocated from was previously downsized)} if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then - PLargeBlockHeader(Cardinal(Result) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize; + PLargeBlockHeader(PByte(Result) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize; {The user allocated size is stored for large blocks} - LOldUserSize := PLargeBlockHeader(Cardinal(APointer) - LargeBlockHeaderSize).UserAllocatedSize; + LOldUserSize := PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).UserAllocatedSize; {The number of bytes to move is the old user size.} {$ifdef UseCustomVariableSizeMoveRoutines} - MoveX16L4(APointer^, Result^, LOldUserSize); + MoveX16LP(APointer^, Result^, LOldUserSize); {$else} System.Move(APointer^, Result^, LOldUserSize); {$endif} @@ -3296,12 +4063,12 @@ function ReallocateLargeBlock(APointer: Pointer; ANewSize: Cardinal): Pointer; begin {It's a downsize: do we need to reallocate? Only if the new size is less than half the old size} - if Cardinal(ANewSize) >= (LOldAvailableSize shr 1) then + if ANewSize >= (LOldAvailableSize shr 1) then begin {No need to reallocate} Result := APointer; {Update the requested size} - PLargeBlockHeader(Cardinal(APointer) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize; + PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize; end else begin @@ -3312,13 +4079,13 @@ function ReallocateLargeBlock(APointer: Pointer; ANewSize: Cardinal): Pointer; begin {Still a large block? -> Set the user size} if ANewSize > (MaximumMediumBlockSize - BlockHeaderSize) then - PLargeBlockHeader(Cardinal(APointer) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize; + PLargeBlockHeader(PByte(APointer) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize; {Move the data across} {$ifdef UseCustomVariableSizeMoveRoutines} {$ifdef Align16Bytes} - MoveX16L4(APointer^, Result^, ANewSize); + MoveX16LP(APointer^, Result^, ANewSize); {$else} - MoveX8L4(APointer^, Result^, ANewSize); + MoveX8LP(APointer^, Result^, ANewSize); {$endif} {$else} System.Move(APointer^, Result^, ANewSize); @@ -3333,30 +4100,32 @@ function ReallocateLargeBlock(APointer: Pointer; ANewSize: Cardinal): Pointer; {---------------------Replacement Memory Manager Interface---------------------} +{Replacement for SysGetMem} + +function FastGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; {$ifndef ASMVersion} -{Replacement for SysGetMem (pascal version)} -function FastGetMem(ASize: Integer): Pointer; var LMediumBlock{$ifndef FullDebugMode}, LNextFreeBlock, LSecondSplit{$endif}: PMediumFreeBlock; - LNextMediumBlockHeader: PCardinal; - LBlockSize, LAvailableBlockSize{$ifndef FullDebugMode}, LSecondSplitSize{$endif}: Cardinal; + LNextMediumBlockHeader: PNativeUInt; + LBlockSize, LAvailableBlockSize{$ifndef FullDebugMode}, LSecondSplitSize{$endif}, + LSequentialFeedFreeSize: NativeUInt; LPSmallBlockType: PSmallBlockType; LPSmallBlockPool, LPNewFirstPool: PSmallBlockPoolHeader; - LBinNumber: Cardinal; LNewFirstFreeBlock: Pointer; LPMediumBin: PMediumFreeBlock; - LSequentialFeedFreeSize: Cardinal; - {$ifndef FullDebugMode}LBinGroupsMasked, {$endif}LBinGroupMasked, LBinGroupNumber: Cardinal; + LBinNumber, {$ifndef FullDebugMode}LBinGroupsMasked, {$endif}LBinGroupMasked, + LBinGroupNumber: Cardinal; begin {Is it a small block? -> Take the header size into account when determining the required block size} - if Cardinal(ASize) <= (MaximumSmallBlockSize - BlockHeaderSize) then + if NativeUInt(ASize) <= (MaximumSmallBlockSize - BlockHeaderSize) then begin {-------------------------Allocate a small block---------------------------} {Get the block type from the size} LPSmallBlockType := PSmallBlockType(AllocSize2SmallBlockTypeIndX4[ - (Cardinal(ASize) + (BlockHeaderSize - 1)) div SmallBlockGranularity] * 8 - + Cardinal(@SmallBlockTypes)); + (NativeUInt(ASize) + (BlockHeaderSize - 1)) div SmallBlockGranularity] + * (SizeOf(TSmallBlockType) div 4) + + UIntPtr(@SmallBlockTypes)); {Lock the block type} {$ifndef AssumeMultiThreaded} if IsMultiThread then @@ -3368,16 +4137,20 @@ function FastGetMem(ASize: Integer): Pointer; if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then Break; {Try the next block type} - Inc(Cardinal(LPSmallBlockType), SizeOf(TSmallBlockType)); + Inc(PByte(LPSmallBlockType), SizeOf(TSmallBlockType)); if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then Break; {Try up to two sizes past the requested size} - Inc(Cardinal(LPSmallBlockType), SizeOf(TSmallBlockType)); + Inc(PByte(LPSmallBlockType), SizeOf(TSmallBlockType)); if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then Break; {All three sizes locked - given up and sleep} - Dec(Cardinal(LPSmallBlockType), 2 * SizeOf(TSmallBlockType)); -{$ifndef NeverSleepOnThreadContention} + Dec(PByte(LPSmallBlockType), 2 * SizeOf(TSmallBlockType)); +{$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThread; + {$endif} +{$else} {Both this block type and the next is in use: sleep} Sleep(InitialSleepTime); {Try the lock again} @@ -3391,22 +4164,22 @@ function FastGetMem(ASize: Integer): Pointer; {Get the first pool with free blocks} LPSmallBlockPool := LPSmallBlockType.NextPartiallyFreePool; {Is the pool valid?} - if Cardinal(LPSmallBlockPool) <> Cardinal(LPSmallBlockType) then + if UIntPtr(LPSmallBlockPool) <> UIntPtr(LPSmallBlockType) then begin {Get the first free offset} Result := LPSmallBlockPool.FirstFreeBlock; {Get the new first free block} - LNewFirstFreeBlock := PPointer(Cardinal(Result) - 4)^; + LNewFirstFreeBlock := PPointer(PByte(Result) - BlockHeaderSize)^; {$ifdef CheckHeapForCorruption} {The block should be free} - if (Cardinal(LNewFirstFreeBlock) and ExtractSmallFlagsMask) <> IsFreeBlockFlag then + if (NativeUInt(LNewFirstFreeBlock) and ExtractSmallFlagsMask) <> IsFreeBlockFlag then {$ifdef BCB6OrDelphi7AndUp} System.Error(reInvalidPtr); {$else} System.RunError(reInvalidPtr); {$endif} {$endif} - LNewFirstFreeBlock := Pointer(Cardinal(LNewFirstFreeBlock) and DropSmallFlagsMask); + LNewFirstFreeBlock := Pointer(UIntPtr(LNewFirstFreeBlock) and DropSmallFlagsMask); {Increment the number of used blocks} Inc(LPSmallBlockPool.BlocksInUse); {Set the new first free block} @@ -3425,14 +4198,14 @@ function FastGetMem(ASize: Integer): Pointer; {Try to feed a small block sequentially} Result := LPSmallBlockType.NextSequentialFeedBlockAddress; {Can another block fit?} - if Cardinal(Result) <= Cardinal(LPSmallBlockType.MaxSequentialFeedBlockAddress) then + if UIntPtr(Result) <= UIntPtr(LPSmallBlockType.MaxSequentialFeedBlockAddress) then begin {Get the sequential feed block pool} LPSmallBlockPool := LPSmallBlockType.CurrentSequentialFeedPool; {Increment the number of used blocks in the sequential feed pool} Inc(LPSmallBlockPool.BlocksInUse); {Store the next sequential feed block address} - LPSmallBlockType.NextSequentialFeedBlockAddress := Pointer(Cardinal(Result) + LPSmallBlockType.BlockSize); + LPSmallBlockType.NextSequentialFeedBlockAddress := Pointer(PByte(Result) + LPSmallBlockType.BlockSize); end else begin @@ -3470,12 +4243,12 @@ function FastGetMem(ASize: Integer): Pointer; end; end; {Get the size of the available medium block} - LBlockSize := PCardinal(Cardinal(LMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask; + LBlockSize := PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask; {$ifdef CheckHeapForCorruption} {Check that this block is actually free and the next and previous blocks are both in use.} - if ((PCardinal(Cardinal(LMediumBlock) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag)) - or ((PCardinal(Cardinal(LMediumBlock) + (PCardinal(Cardinal(LMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and IsFreeBlockFlag) <> 0) + if ((PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag)) + or ((PNativeUInt(PByte(LMediumBlock) + (PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and IsFreeBlockFlag) <> 0) then begin {$ifdef BCB6OrDelphi7AndUp} @@ -3493,17 +4266,17 @@ function FastGetMem(ASize: Integer): Pointer; {Adjust the block size} LBlockSize := LPSmallBlockType.OptimalBlockPoolSize; {Split the block in two} - LSecondSplit := PMediumFreeBlock(Cardinal(LMediumBlock) + LBlockSize); - PCardinal(Cardinal(LSecondSplit) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); - {Store the size of the second split as the second last dword} - PCardinal(Cardinal(LSecondSplit) + LSecondSplitSize - 8)^ := LSecondSplitSize; + LSecondSplit := PMediumFreeBlock(PByte(LMediumBlock) + LBlockSize); + PNativeUInt(PByte(LSecondSplit) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); + {Store the size of the second split as the second last dword/qword} + PNativeUInt(PByte(LSecondSplit) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize; {Put the remainder in a bin (it will be big enough)} InsertMediumBlockIntoBin(LSecondSplit, LSecondSplitSize); end else begin {Mark this block as used in the block following it} - LNextMediumBlockHeader := PCardinal(Cardinal(LMediumBlock) + LBlockSize - BlockHeaderSize); + LNextMediumBlockHeader := PNativeUInt(PByte(LMediumBlock) + LBlockSize - BlockHeaderSize); LNextMediumBlockHeader^ := LNextMediumBlockHeader^ and (not PreviousMediumBlockIsFreeFlag); end; end @@ -3522,7 +4295,7 @@ function FastGetMem(ASize: Integer): Pointer; else LBlockSize := LSequentialFeedFreeSize; {Get the block} - LMediumBlock := Pointer(Cardinal(LastSequentiallyFedMediumBlock) - LBlockSize); + LMediumBlock := Pointer(PByte(LastSequentiallyFedMediumBlock) - LBlockSize); {Update the sequential feed parameters} LastSequentiallyFedMediumBlock := LMediumBlock; MediumSequentialFeedBytesLeft := LSequentialFeedFreeSize - LBlockSize; @@ -3552,7 +4325,7 @@ function FastGetMem(ASize: Integer): Pointer; {$endif} {Mark this block as in use} {Set the size and flags for this block} - PCardinal(Cardinal(LMediumBlock) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag or IsSmallBlockPoolInUseFlag; + PNativeUInt(PByte(LMediumBlock) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag or IsSmallBlockPoolInUseFlag; {Unlock medium blocks} MediumBlocksLocked := False; {Set up the block pool} @@ -3562,34 +4335,35 @@ function FastGetMem(ASize: Integer): Pointer; LPSmallBlockPool.BlocksInUse := 1; {Set it up for sequential block serving} LPSmallBlockType.CurrentSequentialFeedPool := LPSmallBlockPool; - Result := Pointer(Cardinal(LPSmallBlockPool) + SmallBlockPoolHeaderSize); - LPSmallBlockType.NextSequentialFeedBlockAddress := Pointer(Cardinal(Result) + LPSmallBlockType.BlockSize); - LPSmallBlockType.MaxSequentialFeedBlockAddress := Pointer(Cardinal(LPSmallBlockPool) + LBlockSize - LPSmallBlockType.BlockSize); + Result := Pointer(PByte(LPSmallBlockPool) + SmallBlockPoolHeaderSize); + LPSmallBlockType.NextSequentialFeedBlockAddress := Pointer(PByte(Result) + LPSmallBlockType.BlockSize); + LPSmallBlockType.MaxSequentialFeedBlockAddress := Pointer(PByte(LPSmallBlockPool) + LBlockSize - LPSmallBlockType.BlockSize); end; {$ifdef FullDebugMode} {Clear the user area of the block} - FillDWord(Pointer(Cardinal(Result) + (SizeOf(TFullDebugBlockHeader) + 4))^, - LPSmallBlockType.BlockSize - FullDebugBlockOverhead - 4, - {$ifndef CatchUseOfFreedInterfaces}DebugFillDWord{$else}Cardinal(@VMTBadInterface){$endif}); - {Block was fed sequentially - we need to set a valid debug header} - PFullDebugBlockHeader(Result).HeaderCheckSum := Cardinal(Result); - PCardinal(Cardinal(Result) + SizeOf(TFullDebugBlockHeader))^ := not Cardinal(Result); + DebugFillMem(Pointer(PByte(Result) + (SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt)))^, + LPSmallBlockType.BlockSize - FullDebugBlockOverhead - SizeOf(NativeUInt), + {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif}); + {Block was fed sequentially - we need to set a valid debug header. Use + the block address.} + PFullDebugBlockHeader(Result).HeaderCheckSum := NativeUInt(Result); + PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(Result); {$endif} end; {Unlock the block type} LPSmallBlockType.BlockTypeLocked := False; {Set the block header} - PCardinal(Cardinal(Result) - BlockHeaderSize)^ := Cardinal(LPSmallBlockPool); + PNativeUInt(PByte(Result) - BlockHeaderSize)^ := UIntPtr(LPSmallBlockPool); end else begin {Medium block or Large block?} - if Cardinal(ASize) <= (MaximumMediumBlockSize - BlockHeaderSize) then + if NativeUInt(ASize) <= (MaximumMediumBlockSize - BlockHeaderSize) then begin {------------------------Allocate a medium block--------------------------} {Get the block size and bin number for this block size. Block sizes are rounded up to the next bin size.} - LBlockSize := ((Cardinal(ASize) + (MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset)) + LBlockSize := ((NativeUInt(ASize) + (MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset)) and -MediumBlockGranularity) + MediumBlockSizeOffset; {Get the bin number} LBinNumber := (LBlockSize - MinimumMediumBlockSize) div MediumBlockGranularity; @@ -3632,13 +4406,13 @@ function FastGetMem(ASize: Integer): Pointer; LBlockSize := LSequentialFeedFreeSize; {$endif} {Block can be fed sequentially} - Result := Pointer(Cardinal(LastSequentiallyFedMediumBlock) - LBlockSize); + Result := Pointer(PByte(LastSequentiallyFedMediumBlock) - LBlockSize); {Store the last sequentially fed block} LastSequentiallyFedMediumBlock := Result; {Store the remaining bytes} MediumSequentialFeedBytesLeft := LSequentialFeedFreeSize - LBlockSize; {Set the flags for the block} - PCardinal(Cardinal(Result) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag; + PNativeUInt(PByte(Result) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag; end else begin @@ -3649,12 +4423,12 @@ function FastGetMem(ASize: Integer): Pointer; {Block was fed sequentially - we need to set a valid debug header} if Result <> nil then begin - PFullDebugBlockHeader(Result).HeaderCheckSum := Cardinal(Result); - PCardinal(Cardinal(Result) + SizeOf(TFullDebugBlockHeader))^ := not Cardinal(Result); + PFullDebugBlockHeader(Result).HeaderCheckSum := NativeUInt(Result); + PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader))^ := not NativeUInt(Result); {Clear the user area of the block} - FillDWord(Pointer(Cardinal(Result) + SizeOf(TFullDebugBlockHeader) + 4)^, - LBlockSize - FullDebugBlockOverhead - 4, - {$ifndef CatchUseOfFreedInterfaces}DebugFillDWord{$else}Cardinal(@VMTBadInterface){$endif}); + DebugFillMem(Pointer(PByte(Result) + SizeOf(TFullDebugBlockHeader) + SizeOf(NativeUInt))^, + LBlockSize - FullDebugBlockOverhead - SizeOf(NativeUInt), + {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif}); end; {$endif} {Done} @@ -3673,9 +4447,9 @@ function FastGetMem(ASize: Integer): Pointer; {$ifdef CheckHeapForCorruption} {Check that this block is actually free and the next and previous blocks are both in use (except in full debug mode).} - if ((PCardinal(Cardinal(Result) - BlockHeaderSize)^ and {$ifndef FullDebugMode}ExtractMediumAndLargeFlagsMask{$else}(IsMediumBlockFlag or IsFreeBlockFlag){$endif}) <> (IsFreeBlockFlag or IsMediumBlockFlag)) + if ((PNativeUInt(PByte(Result) - BlockHeaderSize)^ and {$ifndef FullDebugMode}ExtractMediumAndLargeFlagsMask{$else}(IsMediumBlockFlag or IsFreeBlockFlag){$endif}) <> (IsFreeBlockFlag or IsMediumBlockFlag)) {$ifndef FullDebugMode} - or ((PCardinal(Cardinal(Result) + (PCardinal(Cardinal(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and (ExtractMediumAndLargeFlagsMask - IsSmallBlockPoolInUseFlag)) <> (IsMediumBlockFlag or PreviousMediumBlockIsFreeFlag)) + or ((PNativeUInt(PByte(Result) + (PNativeUInt(PByte(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and (ExtractMediumAndLargeFlagsMask - IsSmallBlockPoolInUseFlag)) <> (IsMediumBlockFlag or PreviousMediumBlockIsFreeFlag)) {$endif} then begin @@ -3689,18 +4463,18 @@ function FastGetMem(ASize: Integer): Pointer; {Remove the block from the bin containing it} RemoveMediumFreeBlock(Result); {Get the block size} - LAvailableBlockSize := PCardinal(Cardinal(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask; + LAvailableBlockSize := PNativeUInt(PByte(Result) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask; {$ifndef FullDebugMode} {Is it an exact fit or not?} LSecondSplitSize := LAvailableBlockSize - LBlockSize; if LSecondSplitSize <> 0 then begin {Split the block in two} - LSecondSplit := PMediumFreeBlock(Cardinal(Result) + LBlockSize); + LSecondSplit := PMediumFreeBlock(PByte(Result) + LBlockSize); {Set the size of the second split} - PCardinal(Cardinal(LSecondSplit) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); - {Store the size of the second split as the second last dword} - PCardinal(Cardinal(LSecondSplit) + LSecondSplitSize - 8)^ := LSecondSplitSize; + PNativeUInt(PByte(LSecondSplit) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); + {Store the size of the second split} + PNativeUInt(PByte(LSecondSplit) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize; {Put the remainder in a bin if it is big enough} if LSecondSplitSize >= MinimumMediumBlockSize then InsertMediumBlockIntoBin(LSecondSplit, LSecondSplitSize); @@ -3712,7 +4486,7 @@ function FastGetMem(ASize: Integer): Pointer; LBlockSize := LAvailableBlockSize; {$endif} {Mark this block as used in the block following it} - LNextMediumBlockHeader := Pointer(Cardinal(Result) + LBlockSize - BlockHeaderSize); + LNextMediumBlockHeader := Pointer(PByte(Result) + LBlockSize - BlockHeaderSize); {$ifndef FullDebugMode} {$ifdef CheckHeapForCorruption} {The next block must be in use} @@ -3729,10 +4503,10 @@ function FastGetMem(ASize: Integer): Pointer; {$ifndef FullDebugMode} end; {Set the size and flags for this block} - PCardinal(Cardinal(Result) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag; + PNativeUInt(PByte(Result) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag; {$else} {In full debug mode blocks are never split or coalesced} - Dec(PCardinal(Cardinal(Result) - BlockHeaderSize)^, IsFreeBlockFlag); + Dec(PNativeUInt(PByte(Result) - BlockHeaderSize)^, IsFreeBlockFlag); {$endif} {Unlock the medium blocks} MediumBlocksLocked := False; @@ -3748,8 +4522,7 @@ function FastGetMem(ASize: Integer): Pointer; end; end; {$else} -{Replacement for SysGetMem (asm version)} -function FastGetMem(ASize: Integer): Pointer; +{$ifdef 32Bit} asm {On entry: eax = ASize} @@ -3875,7 +4648,20 @@ function FastGetMem(ASize: Integer): Pointer; je @GotLockOnSmallBlockType {Block type and two sizes larger are all locked - give up and sleep} sub ebx, 2 * Type(TSmallBlockType) -{$ifndef NeverSleepOnThreadContention} +{$ifdef NeverSleepOnThreadContention} + {Pause instruction (improves performance on P4)} + rep nop + {$ifdef UseSwitchToThread} + call SwitchToThread + {$endif} + {Try again} + jmp @LockBlockTypeLoop + {Align branch target} + nop + {$ifndef UseSwitchToThread} + nop + {$endif} +{$else} {Couldn't grab the block type - sleep and try again} push InitialSleepTime call Sleep @@ -3893,14 +4679,6 @@ function FastGetMem(ASize: Integer): Pointer; nop nop nop -{$else} - {Pause instruction (improves performance on P4)} - rep nop - {Try again} - jmp @LockBlockTypeLoop - {Align branch target} - nop - nop {$endif} @AllocateSmallBlockPool: {save additional registers} @@ -4189,212 +4967,616 @@ function FastGetMem(ASize: Integer): Pointer; jns AllocateLargeBlock xor eax, eax end; -{$endif} - -{$ifndef ASMVersion} -{Frees a medium block, returning 0 on success, -1 otherwise} -function FreeMediumBlock(APointer: Pointer): Integer; -var - LNextMediumBlock{$ifndef FullDebugMode}, LPreviousMediumBlock{$endif}: PMediumFreeBlock; - LNextMediumBlockSizeAndFlags: Cardinal; - LBlockSize{$ifndef FullDebugMode}, LPreviousMediumBlockSize{$endif}: Cardinal; -{$ifndef FullDebugMode} - LPPreviousMediumBlockPoolHeader, LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader; -{$endif} - LBlockHeader: Cardinal; -begin - {Get the block header} - LBlockHeader := PCardinal(Cardinal(APointer) - BlockHeaderSize)^; - {Get the medium block size} - LBlockSize := LBlockHeader and DropMediumAndLargeFlagsMask; - {Lock the medium blocks} - LockMediumBlocks; - {Can we combine this block with the next free block?} - LNextMediumBlock := PMediumFreeBlock(Cardinal(APointer) + LBlockSize); - LNextMediumBlockSizeAndFlags := PCardinal(Cardinal(LNextMediumBlock) - BlockHeaderSize)^; -{$ifndef FullDebugMode} -{$ifdef CheckHeapForCorruption} - {Check that this block was flagged as in use in the next block} - if (LNextMediumBlockSizeAndFlags and PreviousMediumBlockIsFreeFlag) <> 0 then -{$ifdef BCB6OrDelphi7AndUp} - System.Error(reInvalidPtr); -{$else} - System.RunError(reInvalidPtr); -{$endif} -{$endif} - if (LNextMediumBlockSizeAndFlags and IsFreeBlockFlag) <> 0 then - begin - {Increase the size of this block} - Inc(LBlockSize, LNextMediumBlockSizeAndFlags and DropMediumAndLargeFlagsMask); - {Remove the next block as well} - if LNextMediumBlockSizeAndFlags >= MinimumMediumBlockSize then - RemoveMediumFreeBlock(LNextMediumBlock); - end - else - begin -{$endif} - {Reset the "previous in use" flag of the next block} - PCardinal(Cardinal(LNextMediumBlock) - BlockHeaderSize)^ := LNextMediumBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag; -{$ifndef FullDebugMode} - end; - {Can we combine this block with the previous free block? We need to - re-read the flags since it could have changed before we could lock the - medium blocks.} - if (PCardinal(Cardinal(APointer) - BlockHeaderSize)^ and PreviousMediumBlockIsFreeFlag) <> 0 then - begin - {Get the size of the free block just before this one} - LPreviousMediumBlockSize := PCardinal(Cardinal(APointer) - 8)^; - {Get the start of the previous block} - LPreviousMediumBlock := PMediumFreeBlock(Cardinal(APointer) - LPreviousMediumBlockSize); -{$ifdef CheckHeapForCorruption} - {Check that the previous block is actually free} - if (PCardinal(Cardinal(LPreviousMediumBlock) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag) then -{$ifdef BCB6OrDelphi7AndUp} - System.Error(reInvalidPtr); {$else} - System.RunError(reInvalidPtr); -{$endif} -{$endif} - {Set the new block size} - Inc(LBlockSize, LPreviousMediumBlockSize); - {This is the new current block} - APointer := LPreviousMediumBlock; - {Remove the previous block from the linked list} - if LPreviousMediumBlockSize >= MinimumMediumBlockSize then - RemoveMediumFreeBlock(LPreviousMediumBlock); - end; -{$ifdef CheckHeapForCorruption} - {Check that the previous block is currently flagged as in use} - if (PCardinal(Cardinal(APointer) - BlockHeaderSize)^ and PreviousMediumBlockIsFreeFlag) <> 0 then -{$ifdef BCB6OrDelphi7AndUp} - System.Error(reInvalidPtr); +{64-bit BASM implementation} +asm + {On entry: + rcx = ASize} + .params 2 + .pushnv rbx + .pushnv rsi + .pushnv rdi + {Since most allocations are for small blocks, determine the small block type + index so long} + lea edx, [ecx + BlockHeaderSize - 1] +{$ifdef Align16Bytes} + shr edx, 4 {$else} - System.RunError(reInvalidPtr); + shr edx, 3 {$endif} + {Preload the addresses of some small block structures} + lea r8, AllocSize2SmallBlockTypeIndX4 + lea rbx, SmallBlockTypes +{$ifndef AssumeMultiThreaded} + {Get the IsMultiThread variable so long} + movzx esi, IsMultiThread {$endif} - {Is the entire medium block pool free, and there are other free blocks - that can fit the largest possible medium block? -> free it. (Except in - full debug mode where medium pools are never freed.)} - if (LBlockSize <> (MediumBlockPoolSize - MediumBlockPoolHeaderSize)) then - begin - {Store the size of the block as well as the flags} - PCardinal(Cardinal(APointer) - BlockHeaderSize)^ := LBlockSize or (IsMediumBlockFlag or IsFreeBlockFlag); + {Is it a small block?} + cmp rcx, (MaximumSmallBlockSize - BlockHeaderSize) + ja @NotASmallBlock + {Get the small block type pointer in rbx} + movzx ecx, byte ptr [r8 + rdx] + shl ecx, 4 //SizeOf(TSmallBlockType) = 64 + add rbx, rcx + {Do we need to lock the block type?} +{$ifndef AssumeMultiThreaded} + test esi, esi + jnz @LockBlockTypeLoop {$else} - {Mark the block as free} - Inc(PCardinal(Cardinal(APointer) - BlockHeaderSize)^, IsFreeBlockFlag); + jmp @LockBlockTypeLoop {$endif} - {Store the trailing size marker} - PCardinal(Cardinal(APointer) + LBlockSize - 8)^ := LBlockSize; - {Insert this block back into the bins: Size check not required here, - since medium blocks that are in use are not allowed to be - shrunk smaller than MinimumMediumBlockSize} - InsertMediumBlockIntoBin(APointer, LBlockSize); -{$ifndef FullDebugMode} -{$ifdef CheckHeapForCorruption} - {Check that this block is actually free and the next and previous blocks are both in use.} - if ((PCardinal(Cardinal(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag)) - or ((PCardinal(Cardinal(APointer) + (PCardinal(Cardinal(APointer) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and IsFreeBlockFlag) <> 0) then - begin -{$ifdef BCB6OrDelphi7AndUp} - System.Error(reInvalidPtr); +@GotLockOnSmallBlockType: + {Find the next free block: Get the first pool with free blocks in rdx} + mov rdx, TSmallBlockType[rbx].NextPartiallyFreePool + {Get the first free block (or the next sequential feed address if rdx = rbx)} + mov rax, TSmallBlockPoolHeader[rdx].FirstFreeBlock + {Get the drop flags mask in rcx so long} + mov rcx, DropSmallFlagsMask + {Is there a pool with free blocks?} + cmp rdx, rbx + je @TrySmallSequentialFeed + {Increment the number of used blocks} + add TSmallBlockPoolHeader[rdx].BlocksInUse, 1 + {Get the new first free block} + and rcx, [rax - BlockHeaderSize] + {Set the new first free block} + mov TSmallBlockPoolHeader[rdx].FirstFreeBlock, rcx + {Set the block header} + mov [rax - BlockHeaderSize], rdx + {Is the chunk now full?} + jz @RemoveSmallPool + {Unlock the block type} + mov TSmallBlockType[rbx].BlockTypeLocked, False + jmp @Done +@TrySmallSequentialFeed: + {Try to feed a small block sequentially: Get the sequential feed block pool} + mov rdx, TSmallBlockType[rbx].CurrentSequentialFeedPool + {Get the next sequential feed address so long} + movzx ecx, TSmallBlockType[rbx].BlockSize + add rcx, rax + {Can another block fit?} + cmp rax, TSmallBlockType[rbx].MaxSequentialFeedBlockAddress + ja @AllocateSmallBlockPool + {Increment the number of used blocks in the sequential feed pool} + add TSmallBlockPoolHeader[rdx].BlocksInUse, 1 + {Store the next sequential feed block address} + mov TSmallBlockType[rbx].NextSequentialFeedBlockAddress, rcx + {Unlock the block type} + mov TSmallBlockType[rbx].BlockTypeLocked, False + {Set the block header} + mov [rax - BlockHeaderSize], rdx + jmp @Done +@RemoveSmallPool: + {Pool is full - remove it from the partially free list} + mov rcx, TSmallBlockPoolHeader[rdx].NextPartiallyFreePool + mov TSmallBlockPoolHeader[rcx].PreviousPartiallyFreePool, rbx + mov TSmallBlockType[rbx].NextPartiallyFreePool, rcx + {Unlock the block type} + mov TSmallBlockType[rbx].BlockTypeLocked, False + jmp @Done +@LockBlockTypeLoop: + mov eax, $100 + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Try the next size} + add rbx, Type(TSmallBlockType) + mov eax, $100 + lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Try the next size (up to two sizes larger)} + add rbx, Type(TSmallBlockType) + mov eax, $100 + lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Block type and two sizes larger are all locked - give up and sleep} + sub rbx, 2 * Type(TSmallBlockType) +{$ifdef NeverSleepOnThreadContention} + {Pause instruction (improves performance on P4)} + pause + {$ifdef UseSwitchToThread} + call SwitchToThread + {$endif} + {Try again} + jmp @LockBlockTypeLoop {$else} - System.RunError(reInvalidPtr); -{$endif} - end; -{$endif} -{$endif} - {Unlock medium blocks} - MediumBlocksLocked := False; - {All OK} - Result := 0; -{$ifndef FullDebugMode} - end - else - begin - {Should this become the new sequential feed?} - if MediumSequentialFeedBytesLeft <> MediumBlockPoolSize - MediumBlockPoolHeaderSize then - begin - {Bin the current sequential feed} - BinMediumSequentialFeedRemainder; - {Set this medium pool up as the new sequential feed pool: - Store the sequential feed pool trailer} - PCardinal(Cardinal(APointer) + LBlockSize - BlockHeaderSize)^ := IsMediumBlockFlag; - {Store the number of bytes available in the sequential feed chunk} - MediumSequentialFeedBytesLeft := MediumBlockPoolSize - MediumBlockPoolHeaderSize; - {Set the last sequentially fed block} - LastSequentiallyFedMediumBlock := Pointer(Cardinal(APointer) + LBlockSize); - {Unlock medium blocks} - MediumBlocksLocked := False; - {Success} - Result := 0; - end - else - begin - {Remove this medium block pool from the linked list} - Dec(Cardinal(APointer), MediumBlockPoolHeaderSize); - LPPreviousMediumBlockPoolHeader := PMediumBlockPoolHeader(APointer).PreviousMediumBlockPoolHeader; - LPNextMediumBlockPoolHeader := PMediumBlockPoolHeader(APointer).NextMediumBlockPoolHeader; - LPPreviousMediumBlockPoolHeader.NextMediumBlockPoolHeader := LPNextMediumBlockPoolHeader; - LPNextMediumBlockPoolHeader.PreviousMediumBlockPoolHeader := LPPreviousMediumBlockPoolHeader; - {Unlock medium blocks} - MediumBlocksLocked := False; - {Free the medium block pool} - if VirtualFree(APointer, 0, MEM_RELEASE) then - Result := 0 - else - Result := -1; - end; - end; + {Couldn't grab the block type - sleep and try again} + mov ecx, InitialSleepTime + call Sleep + {Try again} + mov eax, $100 + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Couldn't grab the block type - sleep and try again} + mov ecx, AdditionalSleepTime + call Sleep + {Try again} + jmp @LockBlockTypeLoop {$endif} -end; - -{Replacement for SysFreeMem (pascal version)} -function FastFreeMem(APointer: Pointer): Integer; -var - LPSmallBlockPool{$ifndef FullDebugMode}, LPPreviousPool, LPNextPool{$endif}, - LPOldFirstPool: PSmallBlockPoolHeader; - LPSmallBlockType: PSmallBlockType; - LOldFirstFreeBlock: Pointer; - LBlockHeader: Cardinal; -begin - {Get the small block header: Is it actually a small block?} - LBlockHeader := PCardinal(Cardinal(APointer) - BlockHeaderSize)^; - {Is it a small block that is in use?} - if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) = 0 then - begin - {Get a pointer to the block pool} - LPSmallBlockPool := PSmallBlockPoolHeader(LBlockHeader); - {Get the block type} - LPSmallBlockType := LPSmallBlockPool.BlockType; - {Lock the block type} +@AllocateSmallBlockPool: + {Do we need to lock the medium blocks?} {$ifndef AssumeMultiThreaded} - if IsMultiThread then -{$endif} - begin - while (LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) <> 0) do - begin -{$ifndef NeverSleepOnThreadContention} - Sleep(InitialSleepTime); - if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then - Break; - Sleep(AdditionalSleepTime); + test esi, esi + jz @MediumBlocksLockedForPool {$endif} - end; - end; - {Get the old first free block} - LOldFirstFreeBlock := LPSmallBlockPool.FirstFreeBlock; - {Was the pool manager previously full?} - if LOldFirstFreeBlock = nil then - begin - {Insert this as the first partially free pool for the block size} - LPOldFirstPool := LPSmallBlockType.NextPartiallyFreePool; + call LockMediumBlocks +@MediumBlocksLockedForPool: + {Are there any available blocks of a suitable size?} + movsx esi, TSmallBlockType[rbx].AllowedGroupsForBlockPoolBitmap + and esi, MediumBlockBinGroupBitmap + jz @NoSuitableMediumBlocks + {Get the bin group number with free blocks in eax} + bsf eax, esi + {Get the bin number in ecx} + lea r8, MediumBlockBinBitmaps + lea r9, [rax * 4] + mov ecx, [r8 + r9] + bsf ecx, ecx + lea ecx, [ecx + r9d * 8] + {Get a pointer to the bin in edi} + lea rdi, MediumBlockBins + lea esi, [ecx * 8] + lea rdi, [rdi + rsi * 2] //SizeOf(TMediumBlockBin) = 16 + {Get the free block in rsi} + mov rsi, TMediumFreeBlock[rdi].NextFreeBlock + {Remove the first block from the linked list (LIFO)} + mov rdx, TMediumFreeBlock[rsi].NextFreeBlock + mov TMediumFreeBlock[rdi].NextFreeBlock, rdx + mov TMediumFreeBlock[rdx].PreviousFreeBlock, rdi + {Is this bin now empty?} + cmp rdi, rdx + jne @MediumBinNotEmpty + {r8 = @MediumBlockBinBitmaps, eax = bin group number, + r9 = bin group number * 4, ecx = bin number, edi = @bin, esi = free block, + ebx = block type} + {Flag this bin as empty} + mov edx, -2 + rol edx, cl + and [r8 + r9], edx + jnz @MediumBinNotEmpty + {Flag the group as empty} + btr MediumBlockBinGroupBitmap, eax +@MediumBinNotEmpty: + {esi = free block, ebx = block type} + {Get the size of the available medium block in edi} + mov rdi, DropMediumAndLargeFlagsMask + and rdi, [rsi - BlockHeaderSize] + cmp edi, MaximumSmallBlockPoolSize + jb @UseWholeBlock + {Split the block: get the size of the second part, new block size is the + optimal size} + mov edx, edi + movzx edi, TSmallBlockType[rbx].OptimalBlockPoolSize + sub edx, edi + {Split the block in two} + lea rcx, [rsi + rdi] + lea rax, [rdx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [rcx - BlockHeaderSize], rax + {Store the size of the second split as the second last qword} + mov [rcx + rdx - BlockHeaderSize * 2], rdx + {Put the remainder in a bin (it will be big enough)} + call InsertMediumBlockIntoBin + jmp @GotMediumBlock +@NoSuitableMediumBlocks: + {Check the sequential feed medium block pool for space} + movzx ecx, TSmallBlockType[rbx].MinimumBlockPoolSize + mov edi, MediumSequentialFeedBytesLeft + cmp edi, ecx + jb @AllocateNewSequentialFeed + {Get the address of the last block that was fed} + mov rsi, LastSequentiallyFedMediumBlock + {Enough sequential feed space: Will the remainder be usable?} + movzx ecx, TSmallBlockType[rbx].OptimalBlockPoolSize + lea edx, [ecx + MinimumMediumBlockSize] + cmp edi, edx + jb @NotMuchSpace + mov edi, ecx +@NotMuchSpace: + sub rsi, rdi + {Update the sequential feed parameters} + sub MediumSequentialFeedBytesLeft, edi + mov LastSequentiallyFedMediumBlock, rsi + {Get the block pointer} + jmp @GotMediumBlock + {Align branch target} +@AllocateNewSequentialFeed: + {Need to allocate a new sequential feed medium block pool: use the + optimal size for this small block pool} + movzx ecx, TSmallBlockType[rbx].OptimalBlockPoolSize + mov edi, ecx + {Allocate the medium block pool} + call AllocNewSequentialFeedMediumPool + mov rsi, rax + test rax, rax + jnz @GotMediumBlock + mov MediumBlocksLocked, al + mov TSmallBlockType[rbx].BlockTypeLocked, al + jmp @Done +@UseWholeBlock: + {rsi = free block, rbx = block type, edi = block size} + {Mark this block as used in the block following it} + and byte ptr [rsi + rdi - BlockHeaderSize], not PreviousMediumBlockIsFreeFlag +@GotMediumBlock: + {rsi = free block, rbx = block type, edi = block size} + {Set the size and flags for this block} + lea ecx, [edi + IsMediumBlockFlag + IsSmallBlockPoolInUseFlag] + mov [rsi - BlockHeaderSize], rcx + {Unlock medium blocks} + xor eax, eax + mov MediumBlocksLocked, al + {Set up the block pool} + mov TSmallBlockPoolHeader[rsi].BlockType, rbx + mov TSmallBlockPoolHeader[rsi].FirstFreeBlock, rax + mov TSmallBlockPoolHeader[rsi].BlocksInUse, 1 + {Set it up for sequential block serving} + mov TSmallBlockType[rbx].CurrentSequentialFeedPool, rsi + {Return the pointer to the first block} + lea rax, [rsi + SmallBlockPoolHeaderSize] + movzx ecx, TSmallBlockType[rbx].BlockSize + lea rdx, [rax + rcx] + mov TSmallBlockType[rbx].NextSequentialFeedBlockAddress, rdx + add rdi, rsi + sub rdi, rcx + mov TSmallBlockType[rbx].MaxSequentialFeedBlockAddress, rdi + {Unlock the small block type} + mov TSmallBlockType[rbx].BlockTypeLocked, False + {Set the small block header} + mov [rax - BlockHeaderSize], rsi + jmp @Done +{-------------------Medium block allocation-------------------} +@NotASmallBlock: + cmp rcx, (MaximumMediumBlockSize - BlockHeaderSize) + ja @IsALargeBlockRequest + {Get the bin size for this block size. Block sizes are + rounded up to the next bin size.} + lea ebx, [ecx + MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset] + and ebx, -MediumBlockGranularity + add ebx, MediumBlockSizeOffset + {Do we need to lock the medium blocks?} +{$ifndef AssumeMultiThreaded} + test esi, esi + jz @MediumBlocksLocked +{$endif} + call LockMediumBlocks +@MediumBlocksLocked: + {Get the bin number in ecx and the group number in edx} + lea edx, [ebx - MinimumMediumBlockSize] + mov ecx, edx + shr edx, 8 + 5 + shr ecx, 8 + {Is there a suitable block inside this group?} + mov eax, -1 + shl eax, cl + lea r8, MediumBlockBinBitmaps + and eax, [r8 + rdx * 4] + jz @GroupIsEmpty + {Get the actual bin number} + and ecx, -32 + bsf eax, eax + or ecx, eax + jmp @GotBinAndGroup +@GroupIsEmpty: + {Try all groups greater than this group} + mov eax, -2 + mov ecx, edx + shl eax, cl + and eax, MediumBlockBinGroupBitmap + jz @TrySequentialFeedMedium + {There is a suitable group with space: get the bin number} + bsf edx, eax + {Get the bin in the group with free blocks} + mov eax, [r8 + rdx * 4] + bsf ecx, eax + mov eax, edx + shl eax, 5 + or ecx, eax + jmp @GotBinAndGroup +@TrySequentialFeedMedium: + mov ecx, MediumSequentialFeedBytesLeft + {Block can be fed sequentially?} + sub ecx, ebx + jc @AllocateNewSequentialFeedForMedium + {Get the block address} + mov rax, LastSequentiallyFedMediumBlock + sub rax, rbx + mov LastSequentiallyFedMediumBlock, rax + {Store the remaining bytes} + mov MediumSequentialFeedBytesLeft, ecx + {Set the flags for the block} + or rbx, IsMediumBlockFlag + mov [rax - BlockHeaderSize], rbx + jmp @MediumBlockGetDone +@AllocateNewSequentialFeedForMedium: + mov ecx, ebx + call AllocNewSequentialFeedMediumPool +@MediumBlockGetDone: + xor cl, cl + mov MediumBlocksLocked, cl //workaround for QC99023 + jmp @Done +@GotBinAndGroup: + {ebx = block size, ecx = bin number, edx = group number} + {Get a pointer to the bin in edi} + lea rdi, MediumBlockBins + lea eax, [ecx + ecx] + lea rdi, [rdi + rax * 8] + {Get the free block in esi} + mov rsi, TMediumFreeBlock[rdi].NextFreeBlock + {Remove the first block from the linked list (LIFO)} + mov rax, TMediumFreeBlock[rsi].NextFreeBlock + mov TMediumFreeBlock[rdi].NextFreeBlock, rax + mov TMediumFreeBlock[rax].PreviousFreeBlock, rdi + {Is this bin now empty?} + cmp rdi, rax + jne @MediumBinNotEmptyForMedium + {edx = bin group number, ecx = bin number, rdi = @bin, rsi = free block, ebx = block size} + {Flag this bin as empty} + mov eax, -2 + rol eax, cl + lea r8, MediumBlockBinBitmaps + and [r8 + rdx * 4], eax + jnz @MediumBinNotEmptyForMedium + {Flag the group as empty} + btr MediumBlockBinGroupBitmap, edx +@MediumBinNotEmptyForMedium: + {rsi = free block, ebx = block size} + {Get the size of the available medium block in edi} + mov rdi, DropMediumAndLargeFlagsMask + and rdi, [rsi - BlockHeaderSize] + {Get the size of the second split in edx} + mov edx, edi + sub edx, ebx + jz @UseWholeBlockForMedium + {Split the block in two} + lea rcx, [rsi + rbx] + lea rax, [rdx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [rcx - BlockHeaderSize], rax + {Store the size of the second split as the second last dword} + mov [rcx + rdx - BlockHeaderSize * 2], rdx + {Put the remainder in a bin} + cmp edx, MinimumMediumBlockSize + jb @GotMediumBlockForMedium + call InsertMediumBlockIntoBin + jmp @GotMediumBlockForMedium +@UseWholeBlockForMedium: + {Mark this block as used in the block following it} + and byte ptr [rsi + rdi - BlockHeaderSize], not PreviousMediumBlockIsFreeFlag +@GotMediumBlockForMedium: + {Set the size and flags for this block} + lea rcx, [rbx + IsMediumBlockFlag] + mov [rsi - BlockHeaderSize], rcx + {Unlock medium blocks} + xor cl, cl + mov MediumBlocksLocked, cl //workaround for QC99023 + mov rax, rsi + jmp @Done +{-------------------Large block allocation-------------------} +@IsALargeBlockRequest: + xor rax, rax + test rcx, rcx + js @Done + call AllocateLargeBlock +@Done: +end; +{$endif} +{$endif} + +{$ifndef ASMVersion} +{Frees a medium block, returning 0 on success, -1 otherwise} +function FreeMediumBlock(APointer: Pointer): Integer; +var + LNextMediumBlock{$ifndef FullDebugMode}, LPreviousMediumBlock{$endif}: PMediumFreeBlock; + LNextMediumBlockSizeAndFlags: NativeUInt; + LBlockSize{$ifndef FullDebugMode}, LPreviousMediumBlockSize{$endif}: Cardinal; +{$ifndef FullDebugMode} + LPPreviousMediumBlockPoolHeader, LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader; +{$endif} + LBlockHeader: NativeUInt; +begin + {Get the block header} + LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^; + {Get the medium block size} + LBlockSize := LBlockHeader and DropMediumAndLargeFlagsMask; + {Lock the medium blocks} + LockMediumBlocks; + {Can we combine this block with the next free block?} + LNextMediumBlock := PMediumFreeBlock(PByte(APointer) + LBlockSize); + LNextMediumBlockSizeAndFlags := PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^; +{$ifndef FullDebugMode} +{$ifdef CheckHeapForCorruption} + {Check that this block was flagged as in use in the next block} + if (LNextMediumBlockSizeAndFlags and PreviousMediumBlockIsFreeFlag) <> 0 then +{$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); +{$else} + System.RunError(reInvalidPtr); +{$endif} +{$endif} + if (LNextMediumBlockSizeAndFlags and IsFreeBlockFlag) <> 0 then + begin + {Increase the size of this block} + Inc(LBlockSize, LNextMediumBlockSizeAndFlags and DropMediumAndLargeFlagsMask); + {Remove the next block as well} + if LNextMediumBlockSizeAndFlags >= MinimumMediumBlockSize then + RemoveMediumFreeBlock(LNextMediumBlock); + end + else + begin +{$endif} + {Reset the "previous in use" flag of the next block} + PNativeUInt(PByte(LNextMediumBlock) - BlockHeaderSize)^ := LNextMediumBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag; +{$ifndef FullDebugMode} + end; + {Can we combine this block with the previous free block? We need to + re-read the flags since it could have changed before we could lock the + medium blocks.} + if (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and PreviousMediumBlockIsFreeFlag) <> 0 then + begin + {Get the size of the free block just before this one} + LPreviousMediumBlockSize := PNativeUInt(PByte(APointer) - 2 * BlockHeaderSize)^; + {Get the start of the previous block} + LPreviousMediumBlock := PMediumFreeBlock(PByte(APointer) - LPreviousMediumBlockSize); +{$ifdef CheckHeapForCorruption} + {Check that the previous block is actually free} + if (PNativeUInt(PByte(LPreviousMediumBlock) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag) then +{$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); +{$else} + System.RunError(reInvalidPtr); +{$endif} +{$endif} + {Set the new block size} + Inc(LBlockSize, LPreviousMediumBlockSize); + {This is the new current block} + APointer := LPreviousMediumBlock; + {Remove the previous block from the linked list} + if LPreviousMediumBlockSize >= MinimumMediumBlockSize then + RemoveMediumFreeBlock(LPreviousMediumBlock); + end; +{$ifdef CheckHeapForCorruption} + {Check that the previous block is currently flagged as in use} + if (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and PreviousMediumBlockIsFreeFlag) <> 0 then +{$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); +{$else} + System.RunError(reInvalidPtr); +{$endif} +{$endif} + {Is the entire medium block pool free, and there are other free blocks + that can fit the largest possible medium block? -> free it. (Except in + full debug mode where medium pools are never freed.)} + if (LBlockSize <> (MediumBlockPoolSize - MediumBlockPoolHeaderSize)) then + begin + {Store the size of the block as well as the flags} + PNativeUInt(PByte(APointer) - BlockHeaderSize)^ := LBlockSize or (IsMediumBlockFlag or IsFreeBlockFlag); +{$else} + {Mark the block as free} + Inc(PNativeUInt(PByte(APointer) - BlockHeaderSize)^, IsFreeBlockFlag); +{$endif} + {Store the trailing size marker} + PNativeUInt(PByte(APointer) + LBlockSize - 2 * BlockHeaderSize)^ := LBlockSize; + {Insert this block back into the bins: Size check not required here, + since medium blocks that are in use are not allowed to be + shrunk smaller than MinimumMediumBlockSize} + InsertMediumBlockIntoBin(APointer, LBlockSize); +{$ifndef FullDebugMode} +{$ifdef CheckHeapForCorruption} + {Check that this block is actually free and the next and previous blocks are both in use.} + if ((PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) <> (IsMediumBlockFlag or IsFreeBlockFlag)) + or ((PNativeUInt(PByte(APointer) + (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask) - BlockHeaderSize)^ and IsFreeBlockFlag) <> 0) then + begin +{$ifdef BCB6OrDelphi7AndUp} + System.Error(reInvalidPtr); +{$else} + System.RunError(reInvalidPtr); +{$endif} + end; +{$endif} +{$endif} + {Unlock medium blocks} + MediumBlocksLocked := False; + {All OK} + Result := 0; +{$ifndef FullDebugMode} + end + else + begin + {Should this become the new sequential feed?} + if MediumSequentialFeedBytesLeft <> MediumBlockPoolSize - MediumBlockPoolHeaderSize then + begin + {Bin the current sequential feed} + BinMediumSequentialFeedRemainder; + {Set this medium pool up as the new sequential feed pool: + Store the sequential feed pool trailer} + PNativeUInt(PByte(APointer) + LBlockSize - BlockHeaderSize)^ := IsMediumBlockFlag; + {Store the number of bytes available in the sequential feed chunk} + MediumSequentialFeedBytesLeft := MediumBlockPoolSize - MediumBlockPoolHeaderSize; + {Set the last sequentially fed block} + LastSequentiallyFedMediumBlock := Pointer(PByte(APointer) + LBlockSize); + {Unlock medium blocks} + MediumBlocksLocked := False; + {Success} + Result := 0; + end + else + begin + {Remove this medium block pool from the linked list} + Dec(PByte(APointer), MediumBlockPoolHeaderSize); + LPPreviousMediumBlockPoolHeader := PMediumBlockPoolHeader(APointer).PreviousMediumBlockPoolHeader; + LPNextMediumBlockPoolHeader := PMediumBlockPoolHeader(APointer).NextMediumBlockPoolHeader; + LPPreviousMediumBlockPoolHeader.NextMediumBlockPoolHeader := LPNextMediumBlockPoolHeader; + LPNextMediumBlockPoolHeader.PreviousMediumBlockPoolHeader := LPPreviousMediumBlockPoolHeader; + {Unlock medium blocks} + MediumBlocksLocked := False; +{$ifdef ClearMediumBlockPoolsBeforeReturningToOS} + FillChar(APointer^, MediumBlockPoolSize, 0); +{$endif} + {Free the medium block pool} + if VirtualFree(APointer, 0, MEM_RELEASE) then + Result := 0 + else + Result := -1; + end; + end; +{$endif} +end; +{$endif} + +{Replacement for SysFreeMem} +function FastFreeMem(APointer: Pointer): Integer; +{$ifndef ASMVersion} +var + LPSmallBlockPool{$ifndef FullDebugMode}, LPPreviousPool, LPNextPool{$endif}, + LPOldFirstPool: PSmallBlockPoolHeader; + LPSmallBlockType: PSmallBlockType; + LOldFirstFreeBlock: Pointer; + LBlockHeader: NativeUInt; +begin + {Get the small block header: Is it actually a small block?} + LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^; + {Is it a small block that is in use?} + if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) = 0 then + begin + {Get a pointer to the block pool} + LPSmallBlockPool := PSmallBlockPoolHeader(LBlockHeader); + {Get the block type} + LPSmallBlockType := LPSmallBlockPool.BlockType; +{$ifdef ClearSmallAndMediumBlocksInFreeMem} + FillChar(APointer^, LPSmallBlockType.BlockSize - BlockHeaderSize, 0); +{$endif} + {Lock the block type} +{$ifndef AssumeMultiThreaded} + if IsMultiThread then +{$endif} + begin + while (LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) <> 0) do + begin +{$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThread; + {$endif} +{$else} + Sleep(InitialSleepTime); + if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then + Break; + Sleep(AdditionalSleepTime); +{$endif} + end; + end; + {Get the old first free block} + LOldFirstFreeBlock := LPSmallBlockPool.FirstFreeBlock; + {Was the pool manager previously full?} + if LOldFirstFreeBlock = nil then + begin + {Insert this as the first partially free pool for the block size} + LPOldFirstPool := LPSmallBlockType.NextPartiallyFreePool; LPSmallBlockPool.NextPartiallyFreePool := LPOldFirstPool; LPOldFirstPool.PreviousPartiallyFreePool := LPSmallBlockPool; LPSmallBlockPool.PreviousPartiallyFreePool := PSmallBlockPoolHeader(LPSmallBlockType); LPSmallBlockType.NextPartiallyFreePool := LPSmallBlockPool; end; {Store the old first free block} - PCardinal(Cardinal(APointer) - BlockHeaderSize)^ := Cardinal(LOldFirstFreeBlock) or IsFreeBlockFlag; + PNativeUInt(PByte(APointer) - BlockHeaderSize)^ := UIntPtr(LOldFirstFreeBlock) or IsFreeBlockFlag; {Store this as the new first free block} LPSmallBlockPool.FirstFreeBlock := APointer; {Decrement the number of allocated blocks} @@ -4403,741 +5585,1563 @@ function FastFreeMem(APointer: Pointer): Integer; likehood of success in catching objects still being used after being destroyed.} {$ifndef FullDebugMode} - {Is the entire pool now free? -> Free it.} - if LPSmallBlockPool.BlocksInUse = 0 then + {Is the entire pool now free? -> Free it.} + if LPSmallBlockPool.BlocksInUse = 0 then + begin + {Get the previous and next chunk managers} + LPPreviousPool := LPSmallBlockPool.PreviousPartiallyFreePool; + LPNextPool := LPSmallBlockPool.NextPartiallyFreePool; + {Remove this manager} + LPPreviousPool.NextPartiallyFreePool := LPNextPool; + LPNextPool.PreviousPartiallyFreePool := LPPreviousPool; + {Is this the sequential feed pool? If so, stop sequential feeding} + if (LPSmallBlockType.CurrentSequentialFeedPool = LPSmallBlockPool) then + LPSmallBlockType.MaxSequentialFeedBlockAddress := nil; + {Unlock this block type} + LPSmallBlockType.BlockTypeLocked := False; + {Free the block pool} + FreeMediumBlock(LPSmallBlockPool); + end + else + begin +{$endif} + {Unlock this block type} + LPSmallBlockType.BlockTypeLocked := False; +{$ifndef FullDebugMode} + end; +{$endif} + {No error} + Result := 0; + end + else + begin + {Is this a medium block or a large block?} + if LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag) = 0 then + begin +{$ifdef ClearSmallAndMediumBlocksInFreeMem} + {Get the block header, extract the block size and clear the block it.} + LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^; + FillChar(APointer^, + (LBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize, 0); +{$endif} + Result := FreeMediumBlock(APointer); + end + else + begin + {Validate: Is this actually a Large block, or is it an attempt to free an + already freed small block?} + if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag) = 0 then + Result := FreeLargeBlock(APointer) + else + Result := -1; + end; + end; +end; +{$else} +{$ifdef 32Bit} +asm + {Get the block header in edx} + mov edx, [eax - 4] + {Is it a small block in use?} + test dl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag + {Save the pointer in ecx} + mov ecx, eax + {Save ebx} + push ebx + {Get the IsMultiThread variable in bl} +{$ifndef AssumeMultiThreaded} + mov bl, IsMultiThread +{$endif} + {Is it a small block that is in use?} + jnz @NotSmallBlockInUse +{$ifdef ClearSmallAndMediumBlocksInFreeMem} + push edx + push ecx + mov edx, TSmallBlockPoolHeader[edx].BlockType + movzx edx, TSmallBlockType(edx).BlockSize + sub edx, BlockHeaderSize + xor ecx, ecx + call System.@FillChar + pop ecx + pop edx +{$endif} + {Do we need to lock the block type?} +{$ifndef AssumeMultiThreaded} + test bl, bl +{$endif} + {Get the small block type in ebx} + mov ebx, TSmallBlockPoolHeader[edx].BlockType + {Do we need to lock the block type?} +{$ifndef AssumeMultiThreaded} + jnz @LockBlockTypeLoop +{$else} + jmp @LockBlockTypeLoop + {Align branch target} + nop +{$endif} +@GotLockOnSmallBlockType: + {Current state: edx = @SmallBlockPoolHeader, ecx = APointer, ebx = @SmallBlockType} + {Decrement the number of blocks in use} + sub TSmallBlockPoolHeader[edx].BlocksInUse, 1 + {Get the old first free block} + mov eax, TSmallBlockPoolHeader[edx].FirstFreeBlock + {Is the pool now empty?} + jz @PoolIsNowEmpty + {Was the pool full?} + test eax, eax + {Store this as the new first free block} + mov TSmallBlockPoolHeader[edx].FirstFreeBlock, ecx + {Store the previous first free block as the block header} + lea eax, [eax + IsFreeBlockFlag] + mov [ecx - 4], eax + {Insert the pool back into the linked list if it was full} + jz @SmallPoolWasFull + {All ok} + xor eax, eax + {Unlock the block type} + mov TSmallBlockType[ebx].BlockTypeLocked, al + {Restore registers} + pop ebx + {Done} + ret + {Align branch target} +{$ifndef AssumeMultiThreaded} + nop +{$endif} +@SmallPoolWasFull: + {Insert this as the first partially free pool for the block size} + mov ecx, TSmallBlockType[ebx].NextPartiallyFreePool + mov TSmallBlockPoolHeader[edx].PreviousPartiallyFreePool, ebx + mov TSmallBlockPoolHeader[edx].NextPartiallyFreePool, ecx + mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, edx + mov TSmallBlockType[ebx].NextPartiallyFreePool, edx + {Unlock the block type} + mov TSmallBlockType[ebx].BlockTypeLocked, False + {All ok} + xor eax, eax + {Restore registers} + pop ebx + {Done} + ret + {Align branch target} + nop + nop +@PoolIsNowEmpty: + {Was this pool actually in the linked list of pools with space? If not, it + can only be the sequential feed pool (it is the only pool that may contain + only one block, i.e. other blocks have not been split off yet)} + test eax, eax + jz @IsSequentialFeedPool + {Pool is now empty: Remove it from the linked list and free it} + mov eax, TSmallBlockPoolHeader[edx].PreviousPartiallyFreePool + mov ecx, TSmallBlockPoolHeader[edx].NextPartiallyFreePool + {Remove this manager} + mov TSmallBlockPoolHeader[eax].NextPartiallyFreePool, ecx + mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, eax + {Zero out eax} + xor eax, eax + {Is this the sequential feed pool? If so, stop sequential feeding} + cmp TSmallBlockType[ebx].CurrentSequentialFeedPool, edx + jne @NotSequentialFeedPool +@IsSequentialFeedPool: + mov TSmallBlockType[ebx].MaxSequentialFeedBlockAddress, eax +@NotSequentialFeedPool: + {Unlock the block type} + mov TSmallBlockType[ebx].BlockTypeLocked, al + {Release this pool} + mov eax, edx + mov edx, [edx - 4] +{$ifndef AssumeMultiThreaded} + mov bl, IsMultiThread +{$endif} + jmp @FreeMediumBlock + {Align branch target} +{$ifndef AssumeMultiThreaded} + nop + nop +{$endif} + nop +@LockBlockTypeLoop: + mov eax, $100 + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah + je @GotLockOnSmallBlockType +{$ifdef NeverSleepOnThreadContention} + {Pause instruction (improves performance on P4)} + rep nop + {$ifdef UseSwitchToThread} + push ecx + push edx + call SwitchToThread + pop edx + pop ecx + {$endif} + {Try again} + jmp @LockBlockTypeLoop + {Align branch target} + {$ifndef UseSwitchToThread} + nop + {$endif} +{$else} + {Couldn't grab the block type - sleep and try again} + push ecx + push edx + push InitialSleepTime + call Sleep + pop edx + pop ecx + {Try again} + mov eax, $100 + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Couldn't grab the block type - sleep and try again} + push ecx + push edx + push AdditionalSleepTime + call Sleep + pop edx + pop ecx + {Try again} + jmp @LockBlockTypeLoop + {Align branch target} + nop + nop +{$endif} + {---------------------Medium blocks------------------------------} + {Align branch target} +@NotSmallBlockInUse: + {Not a small block in use: is it a medium or large block?} + test dl, IsFreeBlockFlag + IsLargeBlockFlag + jnz @NotASmallOrMediumBlock +@FreeMediumBlock: +{$ifdef ClearSmallAndMediumBlocksInFreeMem} + push eax + push edx + and edx, DropMediumAndLargeFlagsMask + sub edx, BlockHeaderSize + xor ecx, ecx + call System.@FillChar + pop edx + pop eax +{$endif} + {Drop the flags} + and edx, DropMediumAndLargeFlagsMask + {Free the medium block pointed to by eax, header in edx, bl = IsMultiThread} +{$ifndef AssumeMultiThreaded} + {Do we need to lock the medium blocks?} + test bl, bl +{$endif} + {Block size in ebx} + mov ebx, edx + {Save registers} + push esi + {Pointer in esi} + mov esi, eax + {Do we need to lock the medium blocks?} +{$ifndef AssumeMultiThreaded} + jz @MediumBlocksLocked +{$endif} + call LockMediumBlocks +@MediumBlocksLocked: + {Can we combine this block with the next free block?} + test dword ptr [esi + ebx - 4], IsFreeBlockFlag + {Get the next block size and flags in ecx} + mov ecx, [esi + ebx - 4] + jnz @NextBlockIsFree + {Set the "PreviousIsFree" flag in the next block} + or ecx, PreviousMediumBlockIsFreeFlag + mov [esi + ebx - 4], ecx +@NextBlockChecked: + {Can we combine this block with the previous free block? We need to + re-read the flags since it could have changed before we could lock the + medium blocks.} + test byte ptr [esi - 4], PreviousMediumBlockIsFreeFlag + jnz @PreviousBlockIsFree +@PreviousBlockChecked: + {Is the entire medium block pool free, and there are other free blocks + that can fit the largest possible medium block -> free it.} + cmp ebx, (MediumBlockPoolSize - MediumBlockPoolHeaderSize) + je @EntireMediumPoolFree +@BinFreeMediumBlock: + {Store the size of the block as well as the flags} + lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [esi - 4], eax + {Store the trailing size marker} + mov [esi + ebx - 8], ebx + {Insert this block back into the bins: Size check not required here, + since medium blocks that are in use are not allowed to be + shrunk smaller than MinimumMediumBlockSize} + mov eax, esi + mov edx, ebx + {Insert into bin} + call InsertMediumBlockIntoBin + {Unlock medium blocks} + mov MediumBlocksLocked, False; + {All OK} + xor eax, eax + {Restore registers} + pop esi + pop ebx + {Return} + ret + {Align branch target} +@NextBlockIsFree: + {Get the next block address in eax} + lea eax, [esi + ebx] + {Increase the size of this block} + and ecx, DropMediumAndLargeFlagsMask + add ebx, ecx + {Was the block binned?} + cmp ecx, MinimumMediumBlockSize + jb @NextBlockChecked + call RemoveMediumFreeBlock + jmp @NextBlockChecked + {Align branch target} + nop +@PreviousBlockIsFree: + {Get the size of the free block just before this one} + mov ecx, [esi - 8] + {Include the previous block} + sub esi, ecx + {Set the new block size} + add ebx, ecx + {Remove the previous block from the linked list} + cmp ecx, MinimumMediumBlockSize + jb @PreviousBlockChecked + mov eax, esi + call RemoveMediumFreeBlock + jmp @PreviousBlockChecked + {Align branch target} +@EntireMediumPoolFree: + {Should we make this the new sequential feed medium block pool? If the + current sequential feed pool is not entirely free, we make this the new + sequential feed pool.} + cmp MediumSequentialFeedBytesLeft, MediumBlockPoolSize - MediumBlockPoolHeaderSize + jne @MakeEmptyMediumPoolSequentialFeed + {Point esi to the medium block pool header} + sub esi, MediumBlockPoolHeaderSize + {Remove this medium block pool from the linked list} + mov eax, TMediumBlockPoolHeader[esi].PreviousMediumBlockPoolHeader + mov edx, TMediumBlockPoolHeader[esi].NextMediumBlockPoolHeader + mov TMediumBlockPoolHeader[eax].NextMediumBlockPoolHeader, edx + mov TMediumBlockPoolHeader[edx].PreviousMediumBlockPoolHeader, eax + {Unlock medium blocks} + mov MediumBlocksLocked, False; +{$ifdef ClearMediumBlockPoolsBeforeReturningToOS} + mov eax, esi + mov edx, MediumBlockPoolSize + xor ecx, ecx + call System.@FillChar +{$endif} + {Free the medium block pool} + push MEM_RELEASE + push 0 + push esi + call VirtualFree + {VirtualFree returns >0 if all is ok} + cmp eax, 1 + {Return 0 on all ok} + sbb eax, eax + {Restore registers} + pop esi + pop ebx + ret + {Align branch target} + nop + nop + nop +@MakeEmptyMediumPoolSequentialFeed: + {Get a pointer to the end-marker block} + lea ebx, [esi + MediumBlockPoolSize - MediumBlockPoolHeaderSize] + {Bin the current sequential feed pool} + call BinMediumSequentialFeedRemainder + {Set this medium pool up as the new sequential feed pool: + Store the sequential feed pool trailer} + mov dword ptr [ebx - BlockHeaderSize], IsMediumBlockFlag + {Store the number of bytes available in the sequential feed chunk} + mov MediumSequentialFeedBytesLeft, MediumBlockPoolSize - MediumBlockPoolHeaderSize + {Set the last sequentially fed block} + mov LastSequentiallyFedMediumBlock, ebx + {Unlock medium blocks} + mov MediumBlocksLocked, False; + {Success} + xor eax, eax + {Restore registers} + pop esi + pop ebx + ret + {Align branch target} + nop + nop +@NotASmallOrMediumBlock: + {Restore ebx} + pop ebx + {Is it in fact a large block?} + test dl, IsFreeBlockFlag + IsMediumBlockFlag + jz FreeLargeBlock + {Attempt to free an already free block} + mov eax, -1 +end; + +{$else} + +{---------------64-bit BASM FastFreeMem---------------} +asm + .params 3 + .pushnv rbx + .pushnv rsi + {Get the block header in rdx} + mov rdx, [rcx - BlockHeaderSize] + {Is it a small block in use?} + test dl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag + {Get the IsMultiThread variable in bl} +{$ifndef AssumeMultiThreaded} + mov bl, IsMultiThread +{$endif} + {Is it a small block that is in use?} + jnz @NotSmallBlockInUse +{$ifdef ClearSmallAndMediumBlocksInFreeMem} + mov rsi, rcx + mov rdx, TSmallBlockPoolHeader[rdx].BlockType + movzx edx, TSmallBlockType(rdx).BlockSize + sub edx, BlockHeaderSize + xor r8, r8 + call System.@FillChar + mov rcx, rsi + mov rdx, [rcx - BlockHeaderSize] +{$endif} + {Do we need to lock the block type?} +{$ifndef AssumeMultiThreaded} + test bl, bl +{$endif} + {Get the small block type in rbx} + mov rbx, TSmallBlockPoolHeader[rdx].BlockType + {Do we need to lock the block type?} +{$ifndef AssumeMultiThreaded} + jnz @LockBlockTypeLoop +{$else} + jmp @LockBlockTypeLoop +{$endif} +@GotLockOnSmallBlockType: + {Current state: rdx = @SmallBlockPoolHeader, rcx = APointer, rbx = @SmallBlockType} + {Decrement the number of blocks in use} + sub TSmallBlockPoolHeader[rdx].BlocksInUse, 1 + {Get the old first free block} + mov rax, TSmallBlockPoolHeader[rdx].FirstFreeBlock + {Is the pool now empty?} + jz @PoolIsNowEmpty + {Was the pool full?} + test rax, rax + {Store this as the new first free block} + mov TSmallBlockPoolHeader[rdx].FirstFreeBlock, rcx + {Store the previous first free block as the block header} + lea rax, [rax + IsFreeBlockFlag] + mov [rcx - BlockHeaderSize], rax + {Insert the pool back into the linked list if it was full} + jz @SmallPoolWasFull + {All ok} + xor eax, eax + {Unlock the block type} + mov TSmallBlockType[rbx].BlockTypeLocked, al + jmp @Done +@SmallPoolWasFull: + {Insert this as the first partially free pool for the block size} + mov rcx, TSmallBlockType[rbx].NextPartiallyFreePool + mov TSmallBlockPoolHeader[rdx].PreviousPartiallyFreePool, rbx + mov TSmallBlockPoolHeader[rdx].NextPartiallyFreePool, rcx + mov TSmallBlockPoolHeader[rcx].PreviousPartiallyFreePool, rdx + mov TSmallBlockType[rbx].NextPartiallyFreePool, rdx + {Unlock the block type} + mov TSmallBlockType[rbx].BlockTypeLocked, False + {All ok} + xor eax, eax + jmp @Done +@PoolIsNowEmpty: + {Was this pool actually in the linked list of pools with space? If not, it + can only be the sequential feed pool (it is the only pool that may contain + only one block, i.e. other blocks have not been split off yet)} + test rax, rax + jz @IsSequentialFeedPool + {Pool is now empty: Remove it from the linked list and free it} + mov rax, TSmallBlockPoolHeader[rdx].PreviousPartiallyFreePool + mov rcx, TSmallBlockPoolHeader[rdx].NextPartiallyFreePool + {Remove this manager} + mov TSmallBlockPoolHeader[rax].NextPartiallyFreePool, rcx + mov TSmallBlockPoolHeader[rcx].PreviousPartiallyFreePool, rax + {Zero out eax} + xor rax, rax + {Is this the sequential feed pool? If so, stop sequential feeding} + cmp TSmallBlockType[rbx].CurrentSequentialFeedPool, rdx + jne @NotSequentialFeedPool +@IsSequentialFeedPool: + mov TSmallBlockType[rbx].MaxSequentialFeedBlockAddress, rax +@NotSequentialFeedPool: + {Unlock the block type} + mov TSmallBlockType[rbx].BlockTypeLocked, al + {Release this pool} + mov rcx, rdx + mov rdx, [rdx - BlockHeaderSize] +{$ifndef AssumeMultiThreaded} + mov bl, IsMultiThread +{$endif} + jmp @FreeMediumBlock +@LockBlockTypeLoop: + mov eax, $100 + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah + je @GotLockOnSmallBlockType +{$ifdef NeverSleepOnThreadContention} + {Pause instruction (improves performance on P4)} + pause + {$ifdef UseSwitchToThread} + mov rsi, rcx + call SwitchToThread + mov rcx, rsi + mov rdx, [rcx - BlockHeaderSize] + {$endif} + {Try again} + jmp @LockBlockTypeLoop +{$else} + {Couldn't grab the block type - sleep and try again} + mov rsi, rcx + mov ecx, InitialSleepTime + call Sleep + mov rcx, rsi + mov rdx, [rcx - BlockHeaderSize] + {Try again} + mov eax, $100 + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([rbx]).BlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Couldn't grab the block type - sleep and try again} + mov rsi, rcx + mov ecx, AdditionalSleepTime + call Sleep + mov rcx, rsi + mov rdx, [rcx - BlockHeaderSize] + {Try again} + jmp @LockBlockTypeLoop +{$endif} + {---------------------Medium blocks------------------------------} +@NotSmallBlockInUse: + {Not a small block in use: is it a medium or large block?} + test dl, IsFreeBlockFlag + IsLargeBlockFlag + jnz @NotASmallOrMediumBlock +@FreeMediumBlock: +{$ifdef ClearSmallAndMediumBlocksInFreeMem} + mov rsi, rcx + and rdx, DropMediumAndLargeFlagsMask + sub rdx, BlockHeaderSize + xor r8, r8 + call System.@FillChar + mov rcx, rsi + mov rdx, [rcx - BlockHeaderSize] +{$endif} + {Drop the flags} + and rdx, DropMediumAndLargeFlagsMask + {Free the medium block pointed to by eax, header in edx, bl = IsMultiThread} +{$ifndef AssumeMultiThreaded} + {Do we need to lock the medium blocks?} + test bl, bl +{$endif} + {Block size in rbx} + mov rbx, rdx + {Pointer in rsi} + mov rsi, rcx + {Do we need to lock the medium blocks?} +{$ifndef AssumeMultiThreaded} + jz @MediumBlocksLocked +{$endif} + call LockMediumBlocks +@MediumBlocksLocked: + {Can we combine this block with the next free block?} + test qword ptr [rsi + rbx - BlockHeaderSize], IsFreeBlockFlag + {Get the next block size and flags in rcx} + mov rcx, [rsi + rbx - BlockHeaderSize] + jnz @NextBlockIsFree + {Set the "PreviousIsFree" flag in the next block} + or rcx, PreviousMediumBlockIsFreeFlag + mov [rsi + rbx - BlockHeaderSize], rcx +@NextBlockChecked: + {Can we combine this block with the previous free block? We need to + re-read the flags since it could have changed before we could lock the + medium blocks.} + test byte ptr [rsi - BlockHeaderSize], PreviousMediumBlockIsFreeFlag + jnz @PreviousBlockIsFree +@PreviousBlockChecked: + {Is the entire medium block pool free, and there are other free blocks + that can fit the largest possible medium block -> free it.} + cmp ebx, (MediumBlockPoolSize - MediumBlockPoolHeaderSize) + je @EntireMediumPoolFree +@BinFreeMediumBlock: + {Store the size of the block as well as the flags} + lea rax, [rbx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [rsi - BlockHeaderSize], rax + {Store the trailing size marker} + mov [rsi + rbx - 2 * BlockHeaderSize], rbx + {Insert this block back into the bins: Size check not required here, + since medium blocks that are in use are not allowed to be + shrunk smaller than MinimumMediumBlockSize} + mov rcx, rsi + mov rdx, rbx + {Insert into bin} + call InsertMediumBlockIntoBin + {All OK} + xor eax, eax + {Unlock medium blocks} + mov MediumBlocksLocked, al + jmp @Done +@NextBlockIsFree: + {Get the next block address in rax} + lea rax, [rsi + rbx] + {Increase the size of this block} + and rcx, DropMediumAndLargeFlagsMask + add rbx, rcx + {Was the block binned?} + cmp rcx, MinimumMediumBlockSize + jb @NextBlockChecked + mov rcx, rax + call RemoveMediumFreeBlock + jmp @NextBlockChecked +@PreviousBlockIsFree: + {Get the size of the free block just before this one} + mov rcx, [rsi - 2 * BlockHeaderSize] + {Include the previous block} + sub rsi, rcx + {Set the new block size} + add rbx, rcx + {Remove the previous block from the linked list} + cmp ecx, MinimumMediumBlockSize + jb @PreviousBlockChecked + mov rcx, rsi + call RemoveMediumFreeBlock + jmp @PreviousBlockChecked +@EntireMediumPoolFree: + {Should we make this the new sequential feed medium block pool? If the + current sequential feed pool is not entirely free, we make this the new + sequential feed pool.} + lea r8, MediumSequentialFeedBytesLeft + cmp dword ptr [r8], MediumBlockPoolSize - MediumBlockPoolHeaderSize //workaround for QC99023 + jne @MakeEmptyMediumPoolSequentialFeed + {Point esi to the medium block pool header} + sub rsi, MediumBlockPoolHeaderSize + {Remove this medium block pool from the linked list} + mov rax, TMediumBlockPoolHeader[rsi].PreviousMediumBlockPoolHeader + mov rdx, TMediumBlockPoolHeader[rsi].NextMediumBlockPoolHeader + mov TMediumBlockPoolHeader[rax].NextMediumBlockPoolHeader, rdx + mov TMediumBlockPoolHeader[rdx].PreviousMediumBlockPoolHeader, rax + {Unlock medium blocks} + xor eax, eax + mov MediumBlocksLocked, al +{$ifdef ClearMediumBlockPoolsBeforeReturningToOS} + mov rcx, rsi + mov edx, MediumBlockPoolSize + xor r8, r8 + call System.@FillChar +{$endif} + {Free the medium block pool} + mov rcx, rsi + xor edx, edx + mov r8d, MEM_RELEASE + call VirtualFree + {VirtualFree returns >0 if all is ok} + cmp eax, 1 + {Return 0 on all ok} + sbb eax, eax + jmp @Done +@MakeEmptyMediumPoolSequentialFeed: + {Get a pointer to the end-marker block} + lea rbx, [rsi + MediumBlockPoolSize - MediumBlockPoolHeaderSize] + {Bin the current sequential feed pool} + call BinMediumSequentialFeedRemainder + {Set this medium pool up as the new sequential feed pool: + Store the sequential feed pool trailer} + mov qword ptr [rbx - BlockHeaderSize], IsMediumBlockFlag + {Store the number of bytes available in the sequential feed chunk} + lea rax, MediumSequentialFeedBytesLeft + mov dword ptr [rax], MediumBlockPoolSize - MediumBlockPoolHeaderSize //QC99023 workaround + {Set the last sequentially fed block} + mov LastSequentiallyFedMediumBlock, rbx + {Success} + xor eax, eax + {Unlock medium blocks} + mov MediumBlocksLocked, al + jmp @Done +@NotASmallOrMediumBlock: + {Attempt to free an already free block?} + mov eax, -1 + {Is it in fact a large block?} + test dl, IsFreeBlockFlag + IsMediumBlockFlag + jnz @Done + call FreeLargeBlock +@Done: +end; +{$endif} +{$endif} + +{$ifndef FullDebugMode} +{Replacement for SysReallocMem} +function FastReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; +{$ifndef ASMVersion} +var + LBlockHeader, LNextBlockSizeAndFlags, LNewAllocSize, LBlockFlags, + LOldAvailableSize, LNextBlockSize, LNewAvailableSize, LMinimumUpsize, + LSecondSplitSize, LNewBlockSize: NativeUInt; + LPSmallBlockType: PSmallBlockType; + LPNextBlock, LPNextBlockHeader: Pointer; + + {Upsizes a large block in-place. The following variables are assumed correct: + LBlockFlags, LOldAvailableSize, LPNextBlock, LNextBlockSizeAndFlags, + LNextBlockSize, LNewAvailableSize. Medium blocks must be locked on entry if + required.} + procedure MediumBlockInPlaceUpsize; + begin + {Remove the next block} + if LNextBlockSizeAndFlags >= MinimumMediumBlockSize then + RemoveMediumFreeBlock(LPNextBlock); + {Add 25% for medium block in-place upsizes} + LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2); + if NativeUInt(ANewSize) < LMinimumUpsize then + LNewAllocSize := LMinimumUpsize + else + LNewAllocSize := NativeUInt(ANewSize); + {Round up to the nearest block size granularity} + LNewBlockSize := ((LNewAllocSize + (BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)) + and -MediumBlockGranularity) + MediumBlockSizeOffset; + {Calculate the size of the second split} + LSecondSplitSize := LNewAvailableSize + BlockHeaderSize - LNewBlockSize; + {Does it fit?} + if NativeInt(LSecondSplitSize) <= 0 then begin - {Get the previous and next chunk managers} - LPPreviousPool := LPSmallBlockPool.PreviousPartiallyFreePool; - LPNextPool := LPSmallBlockPool.NextPartiallyFreePool; - {Remove this manager} - LPPreviousPool.NextPartiallyFreePool := LPNextPool; - LPNextPool.PreviousPartiallyFreePool := LPPreviousPool; - {Is this the sequential feed pool? If so, stop sequential feeding} - if (LPSmallBlockType.CurrentSequentialFeedPool = LPSmallBlockPool) then - LPSmallBlockType.MaxSequentialFeedBlockAddress := nil; - {Unlock this block type} - LPSmallBlockType.BlockTypeLocked := False; - {Free the block pool} - FreeMediumBlock(LPSmallBlockPool); + {The block size is the full available size plus header} + LNewBlockSize := LNewAvailableSize + BlockHeaderSize; + {Grab the whole block: Mark it as used in the block following it} + LPNextBlockHeader := Pointer(PByte(APointer) + LNewAvailableSize); + PNativeUInt(LPNextBlockHeader)^ := + PNativeUInt(LPNextBlockHeader)^ and (not PreviousMediumBlockIsFreeFlag); + end + else + begin + {Split the block in two} + LPNextBlock := PMediumFreeBlock(PByte(APointer) + LNewBlockSize); + {Set the size of the second split} + PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); + {Store the size of the second split before the header of the next block} + PNativeUInt(PByte(LPNextBlock) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize; + {Put the remainder in a bin if it is big enough} + if LSecondSplitSize >= MinimumMediumBlockSize then + InsertMediumBlockIntoBin(LPNextBlock, LSecondSplitSize); + end; + {Set the size and flags for this block} + PNativeUInt(PByte(APointer) - BlockHeaderSize)^ := LNewBlockSize or LBlockFlags; + end; + + {In-place downsize of a medium block. On entry Size must be less than half of + LOldAvailableSize.} + procedure MediumBlockInPlaceDownsize; + begin + {Round up to the next medium block size} + LNewBlockSize := ((ANewSize + (BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)) + and -MediumBlockGranularity) + MediumBlockSizeOffset; + {Get the size of the second split} + LSecondSplitSize := (LOldAvailableSize + BlockHeaderSize) - LNewBlockSize; + {Lock the medium blocks} + LockMediumBlocks; + {Set the new size} + PNativeUInt(PByte(APointer) - BlockHeaderSize)^ := + (PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) + or LNewBlockSize; + {Is the next block in use?} + LPNextBlock := PNativeUInt(PByte(APointer) + LOldAvailableSize + BlockHeaderSize); + LNextBlockSizeAndFlags := PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^; + if LNextBlockSizeAndFlags and IsFreeBlockFlag = 0 then + begin + {The next block is in use: flag its previous block as free} + PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^ := + LNextBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag; + end + else + begin + {The next block is free: combine it} + LNextBlockSizeAndFlags := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask; + Inc(LSecondSplitSize, LNextBlockSizeAndFlags); + if LNextBlockSizeAndFlags >= MinimumMediumBlockSize then + RemoveMediumFreeBlock(LPNextBlock); + end; + {Set the split} + LPNextBlock := PNativeUInt(PByte(APointer) + LNewBlockSize); + {Store the free part's header} + PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); + {Store the trailing size field} + PNativeUInt(PByte(LPNextBlock) + LSecondSplitSize - 2 * BlockHeaderSize)^ := LSecondSplitSize; + {Bin this free block} + if LSecondSplitSize >= MinimumMediumBlockSize then + InsertMediumBlockIntoBin(LPNextBlock, LSecondSplitSize); + {Unlock the medium blocks} + MediumBlocksLocked := False; + end; + +begin + {Get the block header: Is it actually a small block?} + LBlockHeader := PNativeUInt(PByte(APointer) - BlockHeaderSize)^; + {Is it a small block that is in use?} + if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) = 0 then + begin + {-----------------------------------Small block-------------------------------------} + {The block header is a pointer to the block pool: Get the block type} + LPSmallBlockType := PSmallBlockPoolHeader(LBlockHeader).BlockType; + {Get the available size inside blocks of this type.} + LOldAvailableSize := LPSmallBlockType.BlockSize - BlockHeaderSize; + {Is it an upsize or a downsize?} + if LOldAvailableSize >= NativeUInt(ANewSize) then + begin + {It's a downsize. Do we need to allocate a smaller block? Only if the new + block size is less than a quarter of the available size less + SmallBlockDownsizeCheckAdder bytes} + if (NativeUInt(ANewSize) * 4 + SmallBlockDownsizeCheckAdder) >= LOldAvailableSize then + begin + {In-place downsize - return the pointer} + Result := APointer; + Exit; + end + else + begin + {Allocate a smaller block} + Result := FastGetMem(ANewSize); + {Allocated OK?} + if Result <> nil then + begin + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + {$ifdef Align16Bytes} + MoveX16LP(APointer^, Result^, ANewSize); + {$else} + MoveX8LP(APointer^, Result^, ANewSize); + {$endif} +{$else} + System.Move(APointer^, Result^, ANewSize); +{$endif} + {Free the old pointer} + FastFreeMem(APointer); + end; + end; end else begin + {This pointer is being reallocated to a larger block and therefore it is + logical to assume that it may be enlarged again. Since reallocations are + expensive, there is a minimum upsize percentage to avoid unnecessary + future move operations.} + {Must grow with at least 100% + x bytes} + LNewAllocSize := LOldAvailableSize * 2 + SmallBlockUpsizeAdder; + {Still not large enough?} + if LNewAllocSize < NativeUInt(ANewSize) then + LNewAllocSize := NativeUInt(ANewSize); + {Allocate the new block} + Result := FastGetMem(LNewAllocSize); + {Allocated OK?} + if Result <> nil then + begin + {Do we need to store the requested size? Only large blocks store the + requested size.} + if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then + PLargeBlockHeader(PByte(Result) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize; + {Move the data across} +{$ifdef UseCustomFixedSizeMoveRoutines} + LPSmallBlockType.UpsizeMoveProcedure(APointer^, Result^, LOldAvailableSize); +{$else} + System.Move(APointer^, Result^, LOldAvailableSize); {$endif} - {Unlock this block type} - LPSmallBlockType.BlockTypeLocked := False; -{$ifndef FullDebugMode} + {Free the old pointer} + FastFreeMem(APointer); + end; end; -{$endif} - {No error} - Result := 0; end else begin {Is this a medium block or a large block?} if LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag) = 0 then begin - Result := FreeMediumBlock(APointer); - end - else - begin - {Validate: Is this actually a Large block, or is it an attempt to free an - already freed small block?} - if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag) = 0 then - Result := FreeLargeBlock(APointer) - else - Result := -1; - end; - end; -end; -{$else} -{Replacement for SysFreeMem (pascal version)} -function FastFreeMem(APointer: Pointer): Integer; -asm - {Get the block header in edx} - mov edx, [eax - 4] - {Is it a small block in use?} - test dl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag - {Save the pointer in ecx} - mov ecx, eax - {Save ebx} - push ebx - {Get the IsMultiThread variable in bl} + {-------------------------------Medium block--------------------------------------} + {What is the available size in the block being reallocated?} + LOldAvailableSize := (LBlockHeader and DropMediumAndLargeFlagsMask); + {Get a pointer to the next block} + LPNextBlock := PNativeUInt(PByte(APointer) + LOldAvailableSize); + {Subtract the block header size from the old available size} + Dec(LOldAvailableSize, BlockHeaderSize); + {Is it an upsize or a downsize?} + if NativeUInt(ANewSize) > LOldAvailableSize then + begin + {Can we do an in-place upsize?} + LNextBlockSizeAndFlags := PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^; + {Is the next block free?} + if LNextBlockSizeAndFlags and IsFreeBlockFlag <> 0 then + begin + LNextBlockSize := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask; + {The available size including the next block} + LNewAvailableSize := LOldAvailableSize + LNextBlockSize; + {Can the block fit?} + if NativeUInt(ANewSize) <= LNewAvailableSize then + begin + {The next block is free and there is enough space to grow this + block in place.} {$ifndef AssumeMultiThreaded} - mov bl, IsMultiThread + if IsMultiThread then + begin {$endif} - {Is it a small block that is in use?} - jnz @NotSmallBlockInUse - {Do we need to lock the block type?} + {Multi-threaded application - lock medium blocks and re-read the + information on the blocks.} + LockMediumBlocks; + {Re-read the info for this block} + LBlockFlags := PNativeUInt(PByte(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask; + {Re-read the info for the next block} + LNextBlockSizeAndFlags := PNativeUInt(PByte(LPNextBlock) - BlockHeaderSize)^; + {Recalculate the next block size} + LNextBlockSize := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask; + {The available size including the next block} + LNewAvailableSize := LOldAvailableSize + LNextBlockSize; + {Is the next block still free and the size still sufficient?} + if (LNextBlockSizeAndFlags and IsFreeBlockFlag <> 0) + and (NativeUInt(ANewSize) <= LNewAvailableSize) then + begin + {Upsize the block in-place} + MediumBlockInPlaceUpsize; + {Unlock the medium blocks} + MediumBlocksLocked := False; + {Return the result} + Result := APointer; + {Done} + Exit; + end; + {Couldn't use the block: Unlock the medium blocks} + MediumBlocksLocked := False; {$ifndef AssumeMultiThreaded} - test bl, bl + end + else + begin + {Extract the block flags} + LBlockFlags := ExtractMediumAndLargeFlagsMask and LBlockHeader; + {Upsize the block in-place} + MediumBlockInPlaceUpsize; + {Return the result} + Result := APointer; + {Done} + Exit; + end; {$endif} - {Get the small block type in ebx} - mov ebx, TSmallBlockPoolHeader[edx].BlockType - {Do we need to lock the block type?} -{$ifndef AssumeMultiThreaded} - jnz @LockBlockTypeLoop + end; + end; + {Couldn't upsize in place. Grab a new block and move the data across: + If we have to reallocate and move medium blocks, we grow by at + least 25%} + LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2); + if NativeUInt(ANewSize) < LMinimumUpsize then + LNewAllocSize := LMinimumUpsize + else + LNewAllocSize := NativeUInt(ANewSize); + {Allocate the new block} + Result := FastGetMem(LNewAllocSize); + if Result <> nil then + begin + {If it's a large block - store the actual user requested size} + if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then + PLargeBlockHeader(PByte(Result) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize; + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + MoveX16LP(APointer^, Result^, LOldAvailableSize); {$else} - jmp @LockBlockTypeLoop - {Align branch target} - nop + System.Move(APointer^, Result^, LOldAvailableSize); {$endif} -@GotLockOnSmallBlockType: - {Current state: edx = @SmallBlockPoolHeader, ecx = APointer, ebx = @SmallBlockType} - {Decrement the number of blocks in use} - sub TSmallBlockPoolHeader[edx].BlocksInUse, 1 - {Get the old first free block} - mov eax, TSmallBlockPoolHeader[edx].FirstFreeBlock - {Is the pool now empty?} - jz @PoolIsNowEmpty - {Was the pool full?} - test eax, eax - {Store this as the new first free block} - mov TSmallBlockPoolHeader[edx].FirstFreeBlock, ecx - {Store the previous first free block as the block header} - lea eax, [eax + IsFreeBlockFlag] - mov [ecx - 4], eax - {Insert the pool back into the linked list if it was full} - jz @SmallPoolWasFull - {All ok} - xor eax, eax - {Unlock the block type} - mov TSmallBlockType[ebx].BlockTypeLocked, al - {Restore registers} - pop ebx - {Done} - ret - {Align branch target} -{$ifndef AssumeMultiThreaded} - nop + {Free the old block} + FastFreeMem(APointer); + end; + end + else + begin + {Must be less than half the current size or we don't bother resizing.} + if NativeUInt(ANewSize * 2) >= LOldAvailableSize then + begin + Result := APointer; + end + else + begin + {In-place downsize? Balance the cost of moving the data vs. the cost + of fragmenting the memory pool. Medium blocks in use may never be + smaller than MinimumMediumBlockSize.} + if NativeUInt(ANewSize) >= (MinimumMediumBlockSize - BlockHeaderSize) then + begin + MediumBlockInPlaceDownsize; + Result := APointer; + end + else + begin + {The requested size is less than the minimum medium block size. If + the requested size is less than the threshold value (currently a + quarter of the minimum medium block size), move the data to a small + block, otherwise shrink the medium block to the minimum allowable + medium block size.} + if NativeUInt(ANewSize) >= MediumInPlaceDownsizeLimit then + begin + {The request is for a size smaller than the minimum medium block + size, but not small enough to justify moving data: Reduce the + block size to the minimum medium block size} + ANewSize := MinimumMediumBlockSize - BlockHeaderSize; + {Is it already at the minimum medium block size?} + if LOldAvailableSize > NativeUInt(ANewSize) then + MediumBlockInPlaceDownsize; + Result := APointer; + end + else + begin + {Allocate the new block} + Result := FastGetMem(ANewSize); + if Result <> nil then + begin + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + {$ifdef Align16Bytes} + MoveX16LP(APointer^, Result^, ANewSize); + {$else} + MoveX8LP(APointer^, Result^, ANewSize); + {$endif} +{$else} + System.Move(APointer^, Result^, ANewSize); {$endif} -@SmallPoolWasFull: - {Insert this as the first partially free pool for the block size} - mov ecx, TSmallBlockType[ebx].NextPartiallyFreePool - mov TSmallBlockPoolHeader[edx].PreviousPartiallyFreePool, ebx - mov TSmallBlockPoolHeader[edx].NextPartiallyFreePool, ecx - mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, edx - mov TSmallBlockType[ebx].NextPartiallyFreePool, edx - {Unlock the block type} - mov TSmallBlockType[ebx].BlockTypeLocked, False - {All ok} - xor eax, eax - {Restore registers} + {Free the old block} + FastFreeMem(APointer); + end; + end; + end; + end; + end; + end + else + begin + {Is this a valid large block?} + if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag) = 0 then + begin + {-----------------------Large block------------------------------} + Result := ReallocateLargeBlock(APointer, ANewSize); + end + else + begin + {-----------------------Invalid block------------------------------} + {Bad pointer: probably an attempt to reallocate a free memory block.} + Result := nil; + end; + end; + end; +end; +{$else} +{$ifdef 32Bit} +asm + {On entry: eax = APointer; edx = ANewSize} + {Get the block header: Is it actually a small block?} + mov ecx, [eax - 4] + {Is it a small block?} + test cl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag + {Save ebx} + push ebx + {Save esi} + push esi + {Save the original pointer in esi} + mov esi, eax + {Is it a small block?} + jnz @NotASmallBlock + {-----------------------------------Small block-------------------------------------} + {Get the block type in ebx} + mov ebx, TSmallBlockPoolHeader[ecx].BlockType + {Get the available size inside blocks of this type.} + movzx ecx, TSmallBlockType[ebx].BlockSize + sub ecx, 4 + {Is it an upsize or a downsize?} + cmp ecx, edx + jb @SmallUpsize + {It's a downsize. Do we need to allocate a smaller block? Only if the new + size is less than a quarter of the available size less + SmallBlockDownsizeCheckAdder bytes} + lea ebx, [edx * 4 + SmallBlockDownsizeCheckAdder] + cmp ebx, ecx + jb @NotSmallInPlaceDownsize + {In-place downsize - return the original pointer} + pop esi pop ebx - {Done} ret {Align branch target} nop - nop -@PoolIsNowEmpty: - {Was this pool actually in the linked list of pools with space? If not, it - can only be the sequential feed pool (it is the only pool that may contain - only one block, i.e. other blocks have not been split off yet)} - test eax, eax - jz @IsSequentialFeedPool - {Pool is now empty: Remove it from the linked list and free it} - mov eax, TSmallBlockPoolHeader[edx].PreviousPartiallyFreePool - mov ecx, TSmallBlockPoolHeader[edx].NextPartiallyFreePool - {Remove this manager} - mov TSmallBlockPoolHeader[eax].NextPartiallyFreePool, ecx - mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, eax - {Zero out eax} - xor eax, eax - {Is this the sequential feed pool? If so, stop sequential feeding} - cmp TSmallBlockType[ebx].CurrentSequentialFeedPool, edx - jne @NotSequentialFeedPool -@IsSequentialFeedPool: - mov TSmallBlockType[ebx].MaxSequentialFeedBlockAddress, eax -@NotSequentialFeedPool: - {Unlock the block type} - mov TSmallBlockType[ebx].BlockTypeLocked, al - {Release this pool} +@NotSmallInPlaceDownsize: + {Save the requested size} + mov ebx, edx + {Allocate a smaller block} mov eax, edx - mov edx, [edx - 4] -{$ifndef AssumeMultiThreaded} - mov bl, IsMultiThread -{$endif} - jmp @FreeMediumBlock - {Align branch target} -{$ifndef AssumeMultiThreaded} - nop - nop -{$endif} - nop -@LockBlockTypeLoop: - mov eax, $100 - {Attempt to grab the block type} - lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah - je @GotLockOnSmallBlockType -{$ifndef NeverSleepOnThreadContention} - {Couldn't grab the block type - sleep and try again} - push ecx - push edx - push InitialSleepTime - call Sleep - pop edx - pop ecx - {Try again} - mov eax, $100 - {Attempt to grab the block type} - lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah - je @GotLockOnSmallBlockType - {Couldn't grab the block type - sleep and try again} - push ecx - push edx - push AdditionalSleepTime - call Sleep - pop edx - pop ecx - {Try again} - jmp @LockBlockTypeLoop - {Align branch target} - nop - nop + call FastGetMem + {Allocated OK?} + test eax, eax + jz @SmallDownsizeDone + {Move data across: count in ecx} + mov ecx, ebx + {Destination in edx} + mov edx, eax + {Save the result in ebx} + mov ebx, eax + {Original pointer in eax} + mov eax, esi + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + {$ifdef Align16Bytes} + call MoveX16LP + {$else} + call MoveX8LP + {$endif} {$else} - {Pause instruction (improves performance on P4)} - rep nop - {Try again} - jmp @LockBlockTypeLoop - {Align branch target} - nop -{$endif} - {---------------------Medium blocks------------------------------} - {Align branch target} -@NotSmallBlockInUse: - {Not a small block in use: is it a medium or large block?} - test dl, IsFreeBlockFlag + IsLargeBlockFlag - jnz @NotASmallOrMediumBlock -@FreeMediumBlock: - {Drop the flags} - and edx, DropMediumAndLargeFlagsMask - {Free the large block pointed to by eax, header in edx, bl = IsMultiThread} -{$ifndef AssumeMultiThreaded} - {Do we need to lock the medium blocks?} - test bl, bl -{$endif} - {Block size in ebx} - mov ebx, edx - {Save registers} - push esi - {Pointer in esi} - mov esi, eax - {Do we need to lock the medium blocks?} -{$ifndef AssumeMultiThreaded} - jz @MediumBlocksLocked + call System.Move {$endif} - call LockMediumBlocks -@MediumBlocksLocked: - {Can we combine this block with the next free block?} - test dword ptr [esi + ebx - 4], IsFreeBlockFlag - {Get the next block size and flags in ecx} - mov ecx, [esi + ebx - 4] - jnz @NextBlockIsFree - {Set the "PreviousIsFree" flag in the next block} - or ecx, PreviousMediumBlockIsFreeFlag - mov [esi + ebx - 4], ecx -@NextBlockChecked: - {Can we combine this block with the previous free block? We need to - re-read the flags since it could have changed before we could lock the - medium blocks.} - test byte ptr [esi - 4], PreviousMediumBlockIsFreeFlag - jnz @PreviousBlockIsFree -@PreviousBlockChecked: - {Is the entire medium block pool free, and there are other free blocks - that can fit the largest possible medium block -> free it.} - cmp ebx, (MediumBlockPoolSize - MediumBlockPoolHeaderSize) - je @EntireMediumPoolFree -@BinFreeMediumBlock: - {Store the size of the block as well as the flags} - lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag] - mov [esi - 4], eax - {Store the trailing size marker} - mov [esi + ebx - 8], ebx - {Insert this block back into the bins: Size check not required here, - since medium blocks that are in use are not allowed to be - shrunk smaller than MinimumMediumBlockSize} + {Free the original pointer} mov eax, esi - mov edx, ebx - {Insert into bin} - call InsertMediumBlockIntoBin - {Unlock medium blocks} - mov MediumBlocksLocked, False; - {All OK} - xor eax, eax - {Restore registers} + call FastFreeMem + {Return the pointer} + mov eax, ebx +@SmallDownsizeDone: pop esi pop ebx - {Return} ret {Align branch target} -@NextBlockIsFree: - {Get the next block address in eax} - lea eax, [esi + ebx] - {Increase the size of this block} - and ecx, DropMediumAndLargeFlagsMask - add ebx, ecx - {Was the block binned?} - cmp ecx, MinimumMediumBlockSize - jb @NextBlockChecked - call RemoveMediumFreeBlock - jmp @NextBlockChecked - {Align branch target} nop -@PreviousBlockIsFree: - {Get the size of the free block just before this one} - mov ecx, [esi - 8] - {Include the previous block} - sub esi, ecx - {Set the new block size} - add ebx, ecx - {Remove the previous block from the linked list} - cmp ecx, MinimumMediumBlockSize - jb @PreviousBlockChecked + nop +@SmallUpsize: + {State: esi = APointer, edx = ANewSize, ecx = Current Block Size, ebx = Current Block Type} + {This pointer is being reallocated to a larger block and therefore it is + logical to assume that it may be enlarged again. Since reallocations are + expensive, there is a minimum upsize percentage to avoid unnecessary + future move operations.} + {Small blocks always grow with at least 100% + SmallBlockUpsizeAdder bytes} + lea ecx, [ecx + ecx + SmallBlockUpsizeAdder] + {save edi} + push edi + {Save the requested size in edi} + mov edi, edx + {New allocated size is the maximum of the requested size and the minimum + upsize} + xor eax, eax + sub ecx, edx + adc eax, -1 + and eax, ecx + add eax, edx + {Allocate the new block} + call FastGetMem + {Allocated OK?} + test eax, eax + jz @SmallUpsizeDone + {Do we need to store the requested size? Only large blocks store the + requested size.} + cmp edi, MaximumMediumBlockSize - BlockHeaderSize + jbe @NotSmallUpsizeToLargeBlock + {Store the user requested size} + mov [eax - 8], edi +@NotSmallUpsizeToLargeBlock: + {Get the size to move across} + movzx ecx, TSmallBlockType[ebx].BlockSize + sub ecx, BlockHeaderSize + {Move to the new block} + mov edx, eax + {Save the result in edi} + mov edi, eax + {Move from the old block} mov eax, esi - call RemoveMediumFreeBlock - jmp @PreviousBlockChecked - {Align branch target} -@EntireMediumPoolFree: - {Should we make this the new sequential feed medium block pool? If the - current sequential feed pool is not entirely free, we make this the new - sequential feed pool.} - cmp MediumSequentialFeedBytesLeft, MediumBlockPoolSize - MediumBlockPoolHeaderSize - jne @MakeEmptyMediumPoolSequentialFeed - {Point esi to the medium block pool header} - sub esi, MediumBlockPoolHeaderSize - {Remove this medium block pool from the linked list} - mov eax, TMediumBlockPoolHeader[esi].PreviousMediumBlockPoolHeader - mov edx, TMediumBlockPoolHeader[esi].NextMediumBlockPoolHeader - mov TMediumBlockPoolHeader[eax].NextMediumBlockPoolHeader, edx - mov TMediumBlockPoolHeader[edx].PreviousMediumBlockPoolHeader, eax - {Unlock medium blocks} - mov MediumBlocksLocked, False; - {Free the medium block pool} - push MEM_RELEASE - push 0 - push esi - call VirtualFree - {VirtualFree returns >0 if all is ok} - cmp eax, 1 - {Return 0 on all ok} - sbb eax, eax - {Restore registers} + {Move the data across} +{$ifdef UseCustomFixedSizeMoveRoutines} + call TSmallBlockType[ebx].UpsizeMoveProcedure +{$else} + call System.Move +{$endif} + {Free the old pointer} + mov eax, esi + call FastFreeMem + {Done} + mov eax, edi +@SmallUpsizeDone: + pop edi pop esi pop ebx ret {Align branch target} nop - nop - nop -@MakeEmptyMediumPoolSequentialFeed: - {Get a pointer to the end-marker block} - lea ebx, [esi + MediumBlockPoolSize - MediumBlockPoolHeaderSize] - {Bin the current sequential feed pool} - call BinMediumSequentialFeedRemainder - {Set this medium pool up as the new sequential feed pool: - Store the sequential feed pool trailer} - mov dword ptr [ebx - BlockHeaderSize], IsMediumBlockFlag - {Store the number of bytes available in the sequential feed chunk} - mov MediumSequentialFeedBytesLeft, MediumBlockPoolSize - MediumBlockPoolHeaderSize - {Set the last sequentially fed block} - mov LastSequentiallyFedMediumBlock, ebx - {Unlock medium blocks} - mov MediumBlocksLocked, False; - {Success} - xor eax, eax +@NotASmallBlock: + {Is this a medium block or a large block?} + test cl, IsFreeBlockFlag + IsLargeBlockFlag + jnz @PossibleLargeBlock + {-------------------------------Medium block--------------------------------------} + {Status: ecx = Current Block Size + Flags, eax/esi = APointer, + edx = Requested Size} + mov ebx, ecx + {Drop the flags from the header} + and ecx, DropMediumAndLargeFlagsMask + {Save edi} + push edi + {Get a pointer to the next block in edi} + lea edi, [eax + ecx] + {Subtract the block header size from the old available size} + sub ecx, BlockHeaderSize + {Get the complete flags in ebx} + and ebx, ExtractMediumAndLargeFlagsMask + {Is it an upsize or a downsize?} + cmp edx, ecx + {Save ebp} + push ebp + {Is it an upsize or a downsize?} + ja @MediumBlockUpsize + {Status: ecx = Current Block Size - 4, bl = Current Block Flags, + edi = @Next Block, eax/esi = APointer, edx = Requested Size} + {Must be less than half the current size or we don't bother resizing.} + lea ebp, [edx + edx] + cmp ebp, ecx + jb @MediumMustDownsize +@MediumNoResize: {Restore registers} + pop ebp + pop edi pop esi pop ebx + {Return} ret {Align branch target} nop nop -@NotASmallOrMediumBlock: - {Restore ebx} - pop ebx - {Is it in fact a large block?} - test dl, IsFreeBlockFlag + IsMediumBlockFlag - jz FreeLargeBlock - {Attempt to free an already free block} - mov eax, -1 -end; + nop +@MediumMustDownsize: + {In-place downsize? Balance the cost of moving the data vs. the cost of + fragmenting the memory pool. Medium blocks in use may never be smaller + than MinimumMediumBlockSize.} + cmp edx, MinimumMediumBlockSize - BlockHeaderSize + jae @MediumBlockInPlaceDownsize + {The requested size is less than the minimum medium block size. If the + requested size is less than the threshold value (currently a quarter of the + minimum medium block size), move the data to a small block, otherwise shrink + the medium block to the minimum allowable medium block size.} + cmp edx, MediumInPlaceDownsizeLimit + jb @MediumDownsizeRealloc + {The request is for a size smaller than the minimum medium block size, but + not small enough to justify moving data: Reduce the block size to the + minimum medium block size} + mov edx, MinimumMediumBlockSize - BlockHeaderSize + {Is it already at the minimum medium block size?} + cmp ecx, edx + jna @MediumNoResize +@MediumBlockInPlaceDownsize: + {Round up to the next medium block size} + lea ebp, [edx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset] + and ebp, -MediumBlockGranularity; + add ebp, MediumBlockSizeOffset + {Get the size of the second split} + add ecx, BlockHeaderSize + sub ecx, ebp + {Lock the medium blocks} +{$ifndef AssumeMultiThreaded} + cmp IsMultiThread, False + je @DoMediumInPlaceDownsize {$endif} - -{$ifndef FullDebugMode} -{$ifndef ASMVersion} -{Replacement for SysReallocMem (pascal version)} -function FastReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; -var - LBlockHeader, LBlockFlags, LOldAvailableSize, LNewAllocSize, - LNextBlockSizeAndFlags, LNextBlockSize, LNewAvailableSize, LMinimumUpsize, - LSecondSPlitSize, LNewBlockSize: Cardinal; - LPSmallBlockType: PSmallBlockType; - LPNextBlock, LPNextBlockHeader: Pointer; - - {Upsizes a large block in-place. The following variables are assumed correct: - LBlockFlags, LOldAvailableSize, LPNextBlock, LNextBlockSizeAndFlags, - LNextBlockSize, LNewAvailableSize. Medium blocks must be locked on entry if - required.} - procedure MediumBlockInPlaceUpsize; - begin - {Remove the next block} - if LNextBlockSizeAndFlags >= MinimumMediumBlockSize then - RemoveMediumFreeBlock(LPNextBlock); - {Add 25% for medium block in-place upsizes} - LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2); - if Cardinal(ANewSize) < LMinimumUpsize then - LNewAllocSize := LMinimumUpsize - else - LNewAllocSize := ANewSize; - {Round up to the nearest block size granularity} - LNewBlockSize := ((LNewAllocSize + (BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)) and -MediumBlockGranularity) + MediumBlockSizeOffset; - {Calculate the size of the second split} - LSecondSplitSize := LNewAvailableSize + BlockHeaderSize - LNewBlockSize; - {Does it fit?} - if Integer(LSecondSplitSize) <= 0 then - begin - {The block size is the full available size plus header} - LNewBlockSize := LNewAvailableSize + BlockHeaderSize; - {Grab the whole block: Mark it as used in the block following it} - LPNextBlockHeader := Pointer(Cardinal(APointer) + LNewAvailableSize); - PCardinal(LPNextBlockHeader)^ := - PCardinal(LPNextBlockHeader)^ and (not PreviousMediumBlockIsFreeFlag); - end - else - begin - {Split the block in two} - LPNextBlock := PMediumFreeBlock(Cardinal(APointer) + LNewBlockSize); - {Set the size of the second split} - PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); - {Store the size of the second split as the second last dword} - PCardinal(Cardinal(LPNextBlock) + LSecondSplitSize - 8)^ := LSecondSplitSize; - {Put the remainder in a bin if it is big enough} - if LSecondSplitSize >= MinimumMediumBlockSize then - InsertMediumBlockIntoBin(LPNextBlock, LSecondSplitSize); - end; - {Set the size and flags for this block} - PCardinal(Cardinal(APointer) - BlockHeaderSize)^ := LNewBlockSize or LBlockFlags; - end; - - {In-place downsize of a medium block. On entry ANewSize must be less than half - of LOldAvailableSize.} - procedure MediumBlockInPlaceDownsize; - begin - {Round up to the next medium block size} - LNewBlockSize := ((ANewSize + (BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)) and -MediumBlockGranularity) + MediumBlockSizeOffset; - {Get the size of the second split} - LSecondSplitSize := (LOldAvailableSize + BlockHeaderSize) - LNewBlockSize; - {Lock the medium blocks} - LockMediumBlocks; - {Set the new size} - PCardinal(Cardinal(APointer) - BlockHeaderSize)^ := - (PCardinal(Cardinal(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) - or LNewBlockSize; - {Is the next block in use?} - LPNextBlock := PCardinal(Cardinal(APointer) + LOldAvailableSize + BlockHeaderSize); - LNextBlockSizeAndFlags := PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^; - if LNextBlockSizeAndFlags and IsFreeBlockFlag = 0 then - begin - {The next block is in use: flag its previous block as free} - PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^ := - LNextBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag; - end - else - begin - {The next block is free: combine it} - LNextBlockSizeAndFlags := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask; - Inc(LSecondSplitSize, LNextBlockSizeAndFlags); - if LNextBlockSizeAndFlags >= MinimumMediumBlockSize then - RemoveMediumFreeBlock(LPNextBlock); - end; - {Set the split} - LPNextBlock := PCardinal(Cardinal(APointer) + LNewBlockSize); - {Store the free part's header} - PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); - {Store the trailing size field} - PCardinal(Cardinal(LPNextBlock) + LSecondSplitSize - 8)^ := LSecondSplitSize; - {Bin this free block} - if LSecondSplitSize >= MinimumMediumBlockSize then - InsertMediumBlockIntoBin(LPNextBlock, LSecondSplitSize); - {Unlock the medium blocks} - MediumBlocksLocked := False; - end; - -begin - {Get the block header: Is it actually a small block?} - LBlockHeader := PCardinal(Cardinal(APointer) - BlockHeaderSize)^; - {Is it a small block that is in use?} - if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) = 0 then - begin - {-----------------------------------Small block-------------------------------------} - {The block header is a pointer to the block pool: Get the block type} - LPSmallBlockType := PSmallBlockPoolHeader(LBlockHeader).BlockType; - {Get the available size inside blocks of this type.} - LOldAvailableSize := LPSmallBlockType.BlockSize - BlockHeaderSize; - {Is it an upsize or a downsize?} - if LOldAvailableSize >= Cardinal(ANewSize) then - begin - {It's a downsize. Do we need to allocate a smaller block? Only if the new - block size is less than a quarter of the available size less - SmallBlockDownsizeCheckAdder bytes} - if (Cardinal(ANewSize) * 4 + SmallBlockDownsizeCheckAdder) >= LOldAvailableSize then - begin - {In-place downsize - return the pointer} - Result := APointer; - Exit; - end - else - begin - {Allocate a smaller block} - Result := FastGetMem(ANewSize); - {Allocated OK?} - if Result <> nil then - begin - {Move the data across} +@DoMediumLockForDownsize: + {Lock the medium blocks (ecx *must* be preserved)} + call LockMediumBlocks + {Reread the flags - they may have changed before medium blocks could be + locked.} + mov ebx, ExtractMediumAndLargeFlagsMask + and ebx, [esi - 4] +@DoMediumInPlaceDownsize: + {Set the new size} + or ebx, ebp + mov [esi - 4], ebx + {Get the second split size in ebx} + mov ebx, ecx + {Is the next block in use?} + mov edx, [edi - 4] + test dl, IsFreeBlockFlag + jnz @MediumDownsizeNextBlockFree + {The next block is in use: flag its previous block as free} + or edx, PreviousMediumBlockIsFreeFlag + mov [edi - 4], edx + jmp @MediumDownsizeDoSplit + {Align branch target} + nop + nop +{$ifdef AssumeMultiThreaded} + nop +{$endif} +@MediumDownsizeNextBlockFree: + {The next block is free: combine it} + mov eax, edi + and edx, DropMediumAndLargeFlagsMask + add ebx, edx + add edi, edx + cmp edx, MinimumMediumBlockSize + jb @MediumDownsizeDoSplit + call RemoveMediumFreeBlock +@MediumDownsizeDoSplit: + {Store the trailing size field} + mov [edi - 8], ebx + {Store the free part's header} + lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag]; + mov [esi + ebp - 4], eax + {Bin this free block} + cmp ebx, MinimumMediumBlockSize + jb @MediumBlockDownsizeDone + lea eax, [esi + ebp] + mov edx, ebx + call InsertMediumBlockIntoBin +@MediumBlockDownsizeDone: + {Unlock the medium blocks} + mov MediumBlocksLocked, False + {Result = old pointer} + mov eax, esi + {Restore registers} + pop ebp + pop edi + pop esi + pop ebx + {Return} + ret + {Align branch target} +@MediumDownsizeRealloc: + {Save the requested size} + mov edi, edx + mov eax, edx + {Allocate the new block} + call FastGetMem + test eax, eax + jz @MediumBlockDownsizeExit + {Save the result} + mov ebp, eax + mov edx, eax + mov eax, esi + mov ecx, edi + {Move the data across} {$ifdef UseCustomVariableSizeMoveRoutines} {$ifdef Align16Bytes} - MoveX16L4(APointer^, Result^, ANewSize); + call MoveX16LP {$else} - MoveX8L4(APointer^, Result^, ANewSize); + call MoveX8LP {$endif} {$else} - System.Move(APointer^, Result^, ANewSize); -{$endif} - {Free the old pointer} - FastFreeMem(APointer); - end; - end; - end - else - begin - {This pointer is being reallocated to a larger block and therefore it is - logical to assume that it may be enlarged again. Since reallocations are - expensive, there is a minimum upsize percentage to avoid unnecessary - future move operations.} - {Must grow with at least 100% + x bytes} - LNewAllocSize := LOldAvailableSize * 2 + SmallBlockUpsizeAdder; - {Still not large enough?} - if LNewAllocSize < Cardinal(ANewSize) then - LNewAllocSize := ANewSize; - {Allocate the new block} - Result := FastGetMem(LNewAllocSize); - {Allocated OK?} - if Result <> nil then - begin - {Do we need to store the requested size? Only large blocks store the - requested size.} - if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then - PLargeBlockHeader(Cardinal(Result) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize; - {Move the data across} -{$ifdef UseCustomFixedSizeMoveRoutines} - LPSmallBlockType.UpsizeMoveProcedure(APointer^, Result^, LOldAvailableSize); -{$else} - System.Move(APointer^, Result^, LOldAvailableSize); -{$endif} - {Free the old pointer} - FastFreeMem(APointer); - end; - end; - end - else - begin - {Is this a medium block or a large block?} - if LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag) = 0 then - begin - {-------------------------------Medium block--------------------------------------} - {What is the available size in the block being reallocated?} - LOldAvailableSize := (LBlockHeader and DropMediumAndLargeFlagsMask); - {Get a pointer to the next block} - LPNextBlock := PCardinal(Cardinal(APointer) + LOldAvailableSize); - {Subtract the block header size from the old available size} - Dec(LOldAvailableSize, BlockHeaderSize); - {Is it an upsize or a downsize?} - if Cardinal(ANewSize) > LOldAvailableSize then - begin - {Can we do an in-place upsize?} - LNextBlockSizeAndFlags := PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^; - {Is the next block free?} - if LNextBlockSizeAndFlags and IsFreeBlockFlag <> 0 then - begin - LNextBlockSize := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask; - {The available size including the next block} - LNewAvailableSize := LOldAvailableSize + LNextBlockSize; - {Can the block fit?} - if Cardinal(ANewSize) <= LNewAvailableSize then - begin - {The next block is free and there is enough space to grow this - block in place.} -{$ifndef AssumeMultiThreaded} - if IsMultiThread then - begin + call System.Move {$endif} - {Multi-threaded application - lock medium blocks and re-read the - information on the blocks.} - LockMediumBlocks; - {Re-read the info for this block} - LBlockFlags := PCardinal(Cardinal(APointer) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask; - {Re-read the info for the next block} - LNextBlockSizeAndFlags := PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^; - {Recalculate the next block size} - LNextBlockSize := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask; - {The available size including the next block} - LNewAvailableSize := LOldAvailableSize + LNextBlockSize; - {Is the next block still free and the size still sufficient?} - if (LNextBlockSizeAndFlags and IsFreeBlockFlag <> 0) - and (Cardinal(ANewSize) <= LNewAvailableSize) then - begin - {Upsize the block in-place} - MediumBlockInPlaceUpsize; - {Unlock the medium blocks} - MediumBlocksLocked := False; - {Return the result} - Result := APointer; - {Done} - Exit; - end; - {Couldn't use the block: Unlock the medium blocks} - MediumBlocksLocked := False; + mov eax, esi + call FastFreeMem + {Return the result} + mov eax, ebp +@MediumBlockDownsizeExit: + pop ebp + pop edi + pop esi + pop ebx + ret + {Align branch target} +@MediumBlockUpsize: + {Status: ecx = Current Block Size - 4, bl = Current Block Flags, + edi = @Next Block, eax/esi = APointer, edx = Requested Size} + {Can we do an in-place upsize?} + mov eax, [edi - 4] + test al, IsFreeBlockFlag + jz @CannotUpsizeMediumBlockInPlace + {Get the total available size including the next block} + and eax, DropMediumAndLargeFlagsMask + {ebp = total available size including the next block (excluding the header)} + lea ebp, [eax + ecx] + {Can the block fit?} + cmp edx, ebp + ja @CannotUpsizeMediumBlockInPlace + {The next block is free and there is enough space to grow this + block in place.} {$ifndef AssumeMultiThreaded} - end - else - begin - {Extract the block flags} - LBlockFlags := ExtractMediumAndLargeFlagsMask and LBlockHeader; - {Upsize the block in-place} - MediumBlockInPlaceUpsize; - {Return the result} - Result := APointer; - {Done} - Exit; - end; + cmp IsMultiThread, False + je @DoMediumInPlaceUpsize {$endif} - end; - end; - {Couldn't upsize in place. Grab a new block and move the data across: - If we have to reallocate and move medium blocks, we grow by at - least 25%} - LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2); - if Cardinal(ANewSize) < LMinimumUpsize then - LNewAllocSize := LMinimumUpsize - else - LNewAllocSize := ANewSize; - {Allocate the new block} - Result := FastGetMem(LNewAllocSize); - if Result <> nil then - begin - {If its a Large block - store the actual user requested size} - if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then - PLargeBlockHeader(Cardinal(Result) - LargeBlockHeaderSize).UserAllocatedSize := ANewSize; - {Move the data across} -{$ifdef UseCustomVariableSizeMoveRoutines} - MoveX16L4(APointer^, Result^, LOldAvailableSize); -{$else} - System.Move(APointer^, Result^, LOldAvailableSize); +@DoMediumLockForUpsize: + {Lock the medium blocks (ecx and edx *must* be preserved} + call LockMediumBlocks + {Re-read the info for this block (since it may have changed before the medium + blocks could be locked)} + mov ebx, ExtractMediumAndLargeFlagsMask + and ebx, [esi - 4] + {Re-read the info for the next block} + mov eax, [edi - 4] + {Next block still free?} + test al, IsFreeBlockFlag + jz @NextMediumBlockChanged + {Recalculate the next block size} + and eax, DropMediumAndLargeFlagsMask + {The available size including the next block} + lea ebp, [eax + ecx] + {Can the block still fit?} + cmp edx, ebp + ja @NextMediumBlockChanged +@DoMediumInPlaceUpsize: + {Is the next block binnable?} + cmp eax, MinimumMediumBlockSize + {Remove the next block} + jb @MediumInPlaceNoNextRemove + mov eax, edi + push ecx + push edx + call RemoveMediumFreeBlock + pop edx + pop ecx +@MediumInPlaceNoNextRemove: + {Medium blocks grow a minimum of 25% in in-place upsizes} + mov eax, ecx + shr eax, 2 + add eax, ecx + {Get the maximum of the requested size and the minimum growth size} + xor edi, edi + sub eax, edx + adc edi, -1 + and eax, edi + {Round up to the nearest block size granularity} + lea eax, [eax + edx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset] + and eax, -MediumBlockGranularity + add eax, MediumBlockSizeOffset + {Calculate the size of the second split} + lea edx, [ebp + BlockHeaderSize] + sub edx, eax + {Does it fit?} + ja @MediumInPlaceUpsizeSplit + {Grab the whole block: Mark it as used in the block following it} + and dword ptr [esi + ebp], not PreviousMediumBlockIsFreeFlag + {The block size is the full available size plus header} + add ebp, 4 + {Upsize done} + jmp @MediumUpsizeInPlaceDone + {Align branch target} +{$ifndef AssumeMultiThreaded} + nop + nop + nop {$endif} - {Free the old block} - FastFreeMem(APointer); - end; - end - else - begin - {Must be less than half the current size or we don't bother resizing.} - if Cardinal(ANewSize * 2) >= LOldAvailableSize then - begin - Result := APointer; - end - else - begin - {In-place downsize? Balance the cost of moving the data vs. the cost - of fragmenting the memory pool. Medium blocks in use may never be - smaller than MinimumMediumBlockSize.} - if ANewSize >= (MinimumMediumBlockSize - BlockHeaderSize) then - begin - MediumBlockInPlaceDownsize; - Result := APointer; - end - else - begin - {The requested size is less than the minimum medium block size. If - the requested size is less than the threshold value (currently a - quarter of the minimum medium block size), move the data to a small - block, otherwise shrink the medium block to the minimum allowable - medium block size.} - if Cardinal(ANewSize) >= MediumInPlaceDownsizeLimit then - begin - {The request is for a size smaller than the minimum medium block - size, but not small enough to justify moving data: Reduce the - block size to the minimum medium block size} - ANewSize := MinimumMediumBlockSize - BlockHeaderSize; - {Is it already at the minimum medium block size?} - if LOldAvailableSize > Cardinal(ANewSize) then - MediumBlockInPlaceDownsize; - Result := APointer; - end - else - begin - {Allocate the new block} - Result := FastGetMem(ANewSize); - if Result <> nil then - begin - {Move the data across} +@MediumInPlaceUpsizeSplit: + {Store the size of the second split as the second last dword} + mov [esi + ebp - 4], edx + {Set the second split header} + lea edi, [edx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [esi + eax - 4], edi + mov ebp, eax + cmp edx, MinimumMediumBlockSize + jb @MediumUpsizeInPlaceDone + add eax, esi + call InsertMediumBlockIntoBin +@MediumUpsizeInPlaceDone: + {Set the size and flags for this block} + or ebp, ebx + mov [esi - 4], ebp + {Unlock the medium blocks} + mov MediumBlocksLocked, False + {Result = old pointer} + mov eax, esi +@MediumBlockResizeDone2: + {Restore registers} + pop ebp + pop edi + pop esi + pop ebx + {Return} + ret + {Align branch target for "@CannotUpsizeMediumBlockInPlace"} + nop + nop +@NextMediumBlockChanged: + {The next medium block changed while the medium blocks were being locked} + mov MediumBlocksLocked, False +@CannotUpsizeMediumBlockInPlace: + {Couldn't upsize in place. Grab a new block and move the data across: + If we have to reallocate and move medium blocks, we grow by at + least 25%} + mov eax, ecx + shr eax, 2 + add eax, ecx + {Get the maximum of the requested size and the minimum growth size} + xor edi, edi + sub eax, edx + adc edi, -1 + and eax, edi + add eax, edx + {Save the size to allocate} + mov ebp, eax + {Save the size to move across} + mov edi, ecx + {Get the block} + push edx + call FastGetMem + pop edx + {Success?} + test eax, eax + jz @MediumBlockResizeDone2 + {If it's a Large block - store the actual user requested size} + cmp ebp, MaximumMediumBlockSize - BlockHeaderSize + jbe @MediumUpsizeNotLarge + mov [eax - 8], edx +@MediumUpsizeNotLarge: + {Save the result} + mov ebp, eax + {Move the data across} + mov edx, eax + mov eax, esi + mov ecx, edi {$ifdef UseCustomVariableSizeMoveRoutines} - {$ifdef Align16Bytes} - MoveX16L4(APointer^, Result^, ANewSize); - {$else} - MoveX8L4(APointer^, Result^, ANewSize); - {$endif} + call MoveX16LP {$else} - System.Move(APointer^, Result^, ANewSize); + call System.Move {$endif} - {Free the old block} - FastFreeMem(APointer); - end; - end; - end; - end; - end; - end - else - begin - {Is this a valid large block?} - if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag) = 0 then - begin - {-----------------------Large block------------------------------} - Result := ReallocateLargeBlock(APointer, ANewSize); - end - else - begin - {-----------------------Invalid block------------------------------} - {Bad pointer: probably an attempt to reallocate a free memory block.} - Result := nil; - end; - end; - end; + {Free the old block} + mov eax, esi + call FastFreeMem + {Restore the result} + mov eax, ebp + {Restore registers} + pop ebp + pop edi + pop esi + pop ebx + {Return} + ret + {Align branch target} + nop +@PossibleLargeBlock: + {-----------------------Large block------------------------------} + {Restore registers} + pop esi + pop ebx + {Is this a valid large block?} + test cl, IsFreeBlockFlag + IsMediumBlockFlag + jz ReallocateLargeBlock + {-----------------------Invalid block------------------------------} + xor eax, eax end; + {$else} -{Replacement for SysReallocMem (asm version)} -function FastReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; + +{-----------------64-bit BASM FastReallocMem-----------------} asm - {On entry: eax = APointer; edx = ANewSize} - {Get the block header: Is it actually a small block?} - mov ecx, [eax - 4] + .params 3 + .pushnv rbx + .pushnv rsi + .pushnv rdi + .pushnv r14 + .pushnv r15 + {On entry: rcx = APointer; rdx = ANewSize} + {Save the original pointer in rsi} + mov rsi, rcx + {Get the block header} + mov rcx, [rcx - BlockHeaderSize] {Is it a small block?} test cl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag - {Save ebx} - push ebx - {Save esi} - push esi - {Save the original pointer in esi} - mov esi, eax - {Is it a small block?} jnz @NotASmallBlock {-----------------------------------Small block-------------------------------------} - {Get the block type in ebx} - mov ebx, TSmallBlockPoolHeader[ecx].BlockType + {Get the block type in rbx} + mov rbx, TSmallBlockPoolHeader[rcx].BlockType {Get the available size inside blocks of this type.} - movzx ecx, TSmallBlockType[ebx].BlockSize - sub ecx, 4 + movzx ecx, TSmallBlockType[rbx].BlockSize + sub ecx, BlockHeaderSize {Is it an upsize or a downsize?} - cmp ecx, edx + cmp rcx, rdx jb @SmallUpsize {It's a downsize. Do we need to allocate a smaller block? Only if the new size is less than a quarter of the available size less @@ -5146,150 +7150,119 @@ function FastReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; cmp ebx, ecx jb @NotSmallInPlaceDownsize {In-place downsize - return the original pointer} - pop esi - pop ebx - ret - {Align branch target} - nop + mov rax, rsi + jmp @Done @NotSmallInPlaceDownsize: {Save the requested size} - mov ebx, edx + mov rbx, rdx {Allocate a smaller block} - mov eax, edx + mov rcx, rdx call FastGetMem {Allocated OK?} - test eax, eax - jz @SmallDownsizeDone - {Move data across: count in ecx} - mov ecx, ebx + test rax, rax + jz @Done + {Move data across: count in r8} + mov r8, rbx {Destination in edx} - mov edx, eax + mov rdx, rax {Save the result in ebx} - mov ebx, eax - {Original pointer in eax} - mov eax, esi + mov rbx, rax + {Original pointer in ecx} + mov rcx, rsi {Move the data across} {$ifdef UseCustomVariableSizeMoveRoutines} {$ifdef Align16Bytes} - call MoveX16L4 + call MoveX16LP {$else} - call MoveX8L4 + call MoveX8LP {$endif} {$else} call System.Move {$endif} {Free the original pointer} - mov eax, esi + mov rcx, rsi call FastFreeMem {Return the pointer} - mov eax, ebx -@SmallDownsizeDone: - pop esi - pop ebx - ret - {Align branch target} - nop - nop + mov rax, rbx + jmp @Done @SmallUpsize: - {State: esi = APointer, edx = ANewSize, ecx = Current Block Size, ebx = Current Block Type} + {State: rsi = APointer, rdx = ANewSize, rcx = Current Block Size, rbx = Current Block Type} {This pointer is being reallocated to a larger block and therefore it is logical to assume that it may be enlarged again. Since reallocations are expensive, there is a minimum upsize percentage to avoid unnecessary future move operations.} {Small blocks always grow with at least 100% + SmallBlockUpsizeAdder bytes} lea ecx, [ecx + ecx + SmallBlockUpsizeAdder] - {save edi} - push edi - {Save the requested size in edi} - mov edi, edx + {Save the requested size in rdi} + mov rdi, rdx {New allocated size is the maximum of the requested size and the minimum upsize} - xor eax, eax - sub ecx, edx - adc eax, -1 - and eax, ecx - add eax, edx + xor rax, rax + sub rcx, rdx + adc rax, -1 + and rcx, rax + add rcx, rdx {Allocate the new block} call FastGetMem {Allocated OK?} - test eax, eax - jz @SmallUpsizeDone + test rax, rax + jz @Done {Do we need to store the requested size? Only large blocks store the requested size.} - cmp edi, MaximumMediumBlockSize - BlockHeaderSize + cmp rdi, MaximumMediumBlockSize - BlockHeaderSize jbe @NotSmallUpsizeToLargeBlock {Store the user requested size} - mov [eax - 8], edi + mov [rax - 2 * BlockHeaderSize], rdi @NotSmallUpsizeToLargeBlock: {Get the size to move across} - movzx ecx, TSmallBlockType[ebx].BlockSize - sub ecx, BlockHeaderSize + movzx r8d, TSmallBlockType[rbx].BlockSize + sub r8d, BlockHeaderSize {Move to the new block} - mov edx, eax + mov rdx, rax {Save the result in edi} - mov edi, eax + mov rdi, rax {Move from the old block} - mov eax, esi + mov rcx, rsi {Move the data across} {$ifdef UseCustomFixedSizeMoveRoutines} - call TSmallBlockType[ebx].UpsizeMoveProcedure + call TSmallBlockType[rbx].UpsizeMoveProcedure {$else} call System.Move {$endif} {Free the old pointer} - mov eax, esi + mov rcx, rsi call FastFreeMem {Done} - mov eax, edi -@SmallUpsizeDone: - pop edi - pop esi - pop ebx - ret - {Align branch target} - nop + mov rax, rdi + jmp @Done @NotASmallBlock: {Is this a medium block or a large block?} test cl, IsFreeBlockFlag + IsLargeBlockFlag jnz @PossibleLargeBlock {-------------------------------Medium block--------------------------------------} - {Status: ecx = Current Block Size + Flags, eax/esi = APointer, - edx = Requested Size} - mov ebx, ecx + {Status: rcx = Current Block Size + Flags, rsi = APointer, + rdx = Requested Size} + mov rbx, rcx {Drop the flags from the header} and ecx, DropMediumAndLargeFlagsMask - {Save edi} - push edi - {Get a pointer to the next block in edi} - lea edi, [eax + ecx] + {Get a pointer to the next block in rdi} + lea rdi, [rsi + rcx] {Subtract the block header size from the old available size} sub ecx, BlockHeaderSize {Get the complete flags in ebx} and ebx, ExtractMediumAndLargeFlagsMask {Is it an upsize or a downsize?} - cmp edx, ecx - {Save ebp} - push ebp - {Is it an upsize or a downsize?} + cmp rdx, rcx ja @MediumBlockUpsize - {Status: ecx = Current Block Size - 4, bl = Current Block Flags, - edi = @Next Block, eax/esi = APointer, edx = Requested Size} + {Status: ecx = Current Block Size - BlockHeaderSize, bl = Current Block Flags, + rdi = @Next Block, rsi = APointer, rdx = Requested Size} {Must be less than half the current size or we don't bother resizing.} - lea ebp, [edx + edx] - cmp ebp, ecx + lea r15, [rdx + rdx] + cmp r15, rcx jb @MediumMustDownsize @MediumNoResize: - {Restore registers} - pop ebp - pop edi - pop esi - pop ebx - {Return} - ret - {Align branch target} - nop - nop - nop + mov rax, rsi + jmp @Done @MediumMustDownsize: {In-place downsize? Balance the cost of moving the data vs. the cost of fragmenting the memory pool. Medium blocks in use may never be smaller @@ -5311,162 +7284,152 @@ function FastReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; jna @MediumNoResize @MediumBlockInPlaceDownsize: {Round up to the next medium block size} - lea ebp, [edx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset] - and ebp, -MediumBlockGranularity; - add ebp, MediumBlockSizeOffset + lea r15, [rdx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset] + and r15, -MediumBlockGranularity + add r15, MediumBlockSizeOffset {Get the size of the second split} add ecx, BlockHeaderSize - sub ecx, ebp + sub ecx, r15d {Lock the medium blocks} {$ifndef AssumeMultiThreaded} - cmp IsMultiThread, False + lea r8, IsMultiThread + cmp byte ptr [r8], False je @DoMediumInPlaceDownsize {$endif} @DoMediumLockForDownsize: - {Lock the medium blocks (ecx *must* be preserved)} + {Lock the medium blocks} + mov ebx, ecx call LockMediumBlocks + mov ecx, ebx {Reread the flags - they may have changed before medium blocks could be locked.} - mov ebx, ExtractMediumAndLargeFlagsMask - and ebx, [esi - 4] + mov rbx, ExtractMediumAndLargeFlagsMask + and rbx, [rsi - BlockHeaderSize] @DoMediumInPlaceDownsize: {Set the new size} - or ebx, ebp - mov [esi - 4], ebx + or rbx, r15 + mov [rsi - BlockHeaderSize], rbx {Get the second split size in ebx} mov ebx, ecx {Is the next block in use?} - mov edx, [edi - 4] + mov rdx, [rdi - BlockHeaderSize] test dl, IsFreeBlockFlag jnz @MediumDownsizeNextBlockFree {The next block is in use: flag its previous block as free} - or edx, PreviousMediumBlockIsFreeFlag - mov [edi - 4], edx + or rdx, PreviousMediumBlockIsFreeFlag + mov [rdi - BlockHeaderSize], rdx jmp @MediumDownsizeDoSplit - {Align branch target} - nop - nop -{$ifdef AssumeMultiThreaded} - nop -{$endif} @MediumDownsizeNextBlockFree: {The next block is free: combine it} - mov eax, edi - and edx, DropMediumAndLargeFlagsMask - add ebx, edx - add edi, edx + mov rcx, rdi + and rdx, DropMediumAndLargeFlagsMask + add rbx, rdx + add rdi, rdx cmp edx, MinimumMediumBlockSize jb @MediumDownsizeDoSplit call RemoveMediumFreeBlock @MediumDownsizeDoSplit: {Store the trailing size field} - mov [edi - 8], ebx + mov [rdi - 2 * BlockHeaderSize], rbx {Store the free part's header} - lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag]; - mov [esi + ebp - 4], eax + lea rcx, [rbx + IsMediumBlockFlag + IsFreeBlockFlag]; + mov [rsi + r15 - BlockHeaderSize], rcx {Bin this free block} - cmp ebx, MinimumMediumBlockSize + cmp rbx, MinimumMediumBlockSize jb @MediumBlockDownsizeDone - lea eax, [esi + ebp] - mov edx, ebx + lea rcx, [rsi + r15] + mov rdx, rbx call InsertMediumBlockIntoBin @MediumBlockDownsizeDone: {Unlock the medium blocks} - mov MediumBlocksLocked, False + lea rax, MediumBlocksLocked + mov byte ptr [rax], False {Result = old pointer} - mov eax, esi - {Restore registers} - pop ebp - pop edi - pop esi - pop ebx - {Return} - ret - {Align branch target} + mov rax, rsi + jmp @Done @MediumDownsizeRealloc: {Save the requested size} - mov edi, edx - mov eax, edx + mov rdi, rdx + mov rcx, rdx {Allocate the new block} call FastGetMem - test eax, eax - jz @MediumBlockDownsizeExit + test rax, rax + jz @Done {Save the result} - mov ebp, eax - mov edx, eax - mov eax, esi - mov ecx, edi + mov r15, rax + mov rdx, rax + mov rcx, rsi + mov r8, rdi {Move the data across} {$ifdef UseCustomVariableSizeMoveRoutines} {$ifdef Align16Bytes} - call MoveX16L4 + call MoveX16LP {$else} - call MoveX8L4 + call MoveX8LP {$endif} {$else} call System.Move {$endif} - mov eax, esi + mov rcx, rsi call FastFreeMem {Return the result} - mov eax, ebp -@MediumBlockDownsizeExit: - pop ebp - pop edi - pop esi - pop ebx - ret - {Align branch target} + mov rax, r15 + jmp @Done @MediumBlockUpsize: - {Status: ecx = Current Block Size - 4, bl = Current Block Flags, - edi = @Next Block, eax/esi = APointer, edx = Requested Size} + {Status: ecx = Current Block Size - BlockHeaderSize, bl = Current Block Flags, + rdi = @Next Block, rsi = APointer, rdx = Requested Size} {Can we do an in-place upsize?} - mov eax, [edi - 4] + mov rax, [rdi - BlockHeaderSize] test al, IsFreeBlockFlag jz @CannotUpsizeMediumBlockInPlace {Get the total available size including the next block} - and eax, DropMediumAndLargeFlagsMask - {ebp = total available size including the next block (excluding the header)} - lea ebp, [eax + ecx] + and rax, DropMediumAndLargeFlagsMask + {r15 = total available size including the next block (excluding the header)} + lea r15, [rax + rcx] {Can the block fit?} - cmp edx, ebp + cmp rdx, r15 ja @CannotUpsizeMediumBlockInPlace {The next block is free and there is enough space to grow this block in place.} {$ifndef AssumeMultiThreaded} - cmp IsMultiThread, False + lea r8, IsMultiThread + cmp byte ptr [r8], False je @DoMediumInPlaceUpsize {$endif} @DoMediumLockForUpsize: - {Lock the medium blocks (ecx and edx *must* be preserved} + {Lock the medium blocks.} + mov rbx, rcx + mov r15, rdx call LockMediumBlocks + mov rcx, rbx + mov rdx, r15 {Re-read the info for this block (since it may have changed before the medium blocks could be locked)} - mov ebx, ExtractMediumAndLargeFlagsMask - and ebx, [esi - 4] + mov rbx, ExtractMediumAndLargeFlagsMask + and rbx, [rsi - BlockHeaderSize] {Re-read the info for the next block} - mov eax, [edi - 4] + mov rax, [rdi - BlockheaderSize] {Next block still free?} test al, IsFreeBlockFlag jz @NextMediumBlockChanged {Recalculate the next block size} and eax, DropMediumAndLargeFlagsMask {The available size including the next block} - lea ebp, [eax + ecx] + lea r15, [rax + rcx] {Can the block still fit?} - cmp edx, ebp + cmp rdx, r15 ja @NextMediumBlockChanged @DoMediumInPlaceUpsize: {Is the next block binnable?} cmp eax, MinimumMediumBlockSize {Remove the next block} jb @MediumInPlaceNoNextRemove - mov eax, edi - push ecx - push edx + mov r14, rcx + mov rcx, rdi + mov rdi, rdx call RemoveMediumFreeBlock - pop edx - pop ecx + mov rcx, r14 + mov rdx, rdi @MediumInPlaceNoNextRemove: {Medium blocks grow a minimum of 25% in in-place upsizes} mov eax, ecx @@ -5482,55 +7445,41 @@ function FastReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; and eax, -MediumBlockGranularity add eax, MediumBlockSizeOffset {Calculate the size of the second split} - lea edx, [ebp + BlockHeaderSize] + lea rdx, [r15 + BlockHeaderSize] sub edx, eax {Does it fit?} ja @MediumInPlaceUpsizeSplit {Grab the whole block: Mark it as used in the block following it} - and dword ptr [esi + ebp], not PreviousMediumBlockIsFreeFlag + and qword ptr [rsi + r15], not PreviousMediumBlockIsFreeFlag {The block size is the full available size plus header} - add ebp, 4 + add r15, BlockHeaderSize {Upsize done} jmp @MediumUpsizeInPlaceDone - {Align branch target} -{$ifndef AssumeMultiThreaded} - nop - nop - nop -{$endif} @MediumInPlaceUpsizeSplit: {Store the size of the second split as the second last dword} - mov [esi + ebp - 4], edx + mov [rsi + r15 - BlockHeaderSize], rdx {Set the second split header} lea edi, [edx + IsMediumBlockFlag + IsFreeBlockFlag] - mov [esi + eax - 4], edi - mov ebp, eax + mov [rsi + rax - BlockHeaderSize], rdi + mov r15, rax cmp edx, MinimumMediumBlockSize jb @MediumUpsizeInPlaceDone - add eax, esi + lea rcx, [rsi + rax] call InsertMediumBlockIntoBin @MediumUpsizeInPlaceDone: {Set the size and flags for this block} - or ebp, ebx - mov [esi - 4], ebp + or r15, rbx + mov [rsi - BlockHeaderSize], r15 {Unlock the medium blocks} - mov MediumBlocksLocked, False + lea rax, MediumBlocksLocked + mov byte ptr [rax], False {Result = old pointer} - mov eax, esi -@MediumBlockResizeDone2: - {Restore registers} - pop ebp - pop edi - pop esi - pop ebx - {Return} - ret - {Align branch target for "@CannotUpsizeMediumBlockInPlace"} - nop - nop + mov rax, rsi + jmp @Done @NextMediumBlockChanged: {The next medium block changed while the medium blocks were being locked} - mov MediumBlocksLocked, False + lea rax, MediumBlocksLocked + mov byte ptr [rax], False @CannotUpsizeMediumBlockInPlace: {Couldn't upsize in place. Grab a new block and move the data across: If we have to reallocate and move medium blocks, we grow by at @@ -5539,69 +7488,66 @@ function FastReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; shr eax, 2 add eax, ecx {Get the maximum of the requested size and the minimum growth size} - xor edi, edi - sub eax, edx - adc edi, -1 - and eax, edi - add eax, edx + xor rdi, rdi + sub rax, rdx + adc rdi, -1 + and rax, rdi + add rax, rdx {Save the size to allocate} - mov ebp, eax + mov r15, rax {Save the size to move across} mov edi, ecx + {Save the requested size} + mov rbx, rdx {Get the block} - push edx + mov rcx, rax call FastGetMem - pop edx + mov rdx, rbx {Success?} test eax, eax - jz @MediumBlockResizeDone2 + jz @Done {If it's a Large block - store the actual user requested size} - cmp ebp, MaximumMediumBlockSize - BlockHeaderSize + cmp r15, MaximumMediumBlockSize - BlockHeaderSize jbe @MediumUpsizeNotLarge - mov [eax - 8], edx + mov [rax - 2 * BlockHeaderSize], rdx @MediumUpsizeNotLarge: {Save the result} - mov ebp, eax + mov r15, rax {Move the data across} - mov edx, eax - mov eax, esi - mov ecx, edi + mov rdx, rax + mov rcx, rsi + mov r8, rdi {$ifdef UseCustomVariableSizeMoveRoutines} - call MoveX16L4 + call MoveX16LP {$else} call System.Move {$endif} {Free the old block} - mov eax, esi + mov rcx, rsi call FastFreeMem {Restore the result} - mov eax, ebp - {Restore registers} - pop ebp - pop edi - pop esi - pop ebx - {Return} - ret - {Align branch target} - nop + mov rax, r15 + jmp @Done @PossibleLargeBlock: {-----------------------Large block------------------------------} - {Restore registers} - pop esi - pop ebx {Is this a valid large block?} test cl, IsFreeBlockFlag + IsMediumBlockFlag - jz ReallocateLargeBlock + jnz @Error + mov rcx, rsi + call ReallocateLargeBlock + jmp @Done {-----------------------Invalid block------------------------------} +@Error: xor eax, eax +@Done: end; {$endif} {$endif} +{$endif} {Allocates a block and fills it with zeroes} +function FastAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer; {$ifndef ASMVersion} -function FastAllocMem(ASize: Cardinal): Pointer; begin Result := FastGetMem(ASize); {Large blocks are already zero filled} @@ -5609,7 +7555,7 @@ function FastAllocMem(ASize: Cardinal): Pointer; FillChar(Result^, ASize, 0); end; {$else} -function FastAllocMem(ASize: Cardinal): Pointer; +{$ifdef 32Bit} asm push ebx {Get the size rounded down to the previous multiple of 4 into ebx} @@ -5623,8 +7569,11 @@ function FastAllocMem(ASize: Cardinal): Pointer; {Point edx to the last dword} lea edx, [eax + ebx] {ebx = $ffffffff if no block could be allocated, otherwise size rounded down - to previous multiple of 4} + to previous multiple of 4. If ebx = 0 then the block size is 1..4 bytes and + the FPU based clearing loop should not be used (since it clears 8 bytes per + iteration).} or ebx, ecx + jz @ClearLastDWord {Large blocks are already zero filled} cmp ebx, MaximumMediumBlockSize - BlockHeaderSize jae @Done @@ -5633,27 +7582,72 @@ function FastAllocMem(ASize: Cardinal): Pointer; {Load zero into st(0)} fldz {Clear groups of 8 bytes. Block sizes are always four less than a multiple - of 8, with a minimum of 12 bytes} + of 8.} @FillLoop: fst qword ptr [edx + ebx] add ebx, 8 js @FillLoop - {Clear the last four bytes} - mov [edx], ecx {Clear st(0)} ffree st(0) {Correct the stack top} fincstp + {Clear the last four bytes} +@ClearLastDWord: + mov [edx], ecx @Done: pop ebx end; + +{$else} + +{---------------64-bit BASM FastAllocMem---------------} +asm + .params 1 + .pushnv rbx + {Get the size rounded down to the previous multiple of SizeOf(Pointer) into + ebx} + lea rbx, [rcx - 1] + and rbx, -8 + {Get the block} + call FastGetMem + {Could a block be allocated? rcx = 0 if yes, -1 if no} + cmp rax, 1 + sbb rcx, rcx + {Point rdx to the last dword} + lea rdx, [rax + rbx] + {rbx = -1 if no block could be allocated, otherwise size rounded down + to previous multiple of 8. If rbx = 0 then the block size is 1..8 bytes and + the SSE2 based clearing loop should not be used (since it clears 16 bytes per + iteration).} + or rbx, rcx + jz @ClearLastQWord + {Large blocks are already zero filled} + cmp rbx, MaximumMediumBlockSize - BlockHeaderSize + jae @Done + {Make the counter negative based} + neg rbx + {Load zero into xmm0} + pxor xmm0, xmm0 + {Clear groups of 16 bytes. Block sizes are always 8 less than a multiple of + 16.} +@FillLoop: + movdqa [rdx + rbx], xmm0 + add rbx, 16 + js @FillLoop + {Clear the last 8 bytes} +@ClearLastQWord: + xor rcx, rcx + mov [rdx], rcx +@Done: +end; +{$endif} {$endif} {-----------------Post Uninstall GetMem/FreeMem/ReallocMem-------------------} {$ifdef DetectMMOperationsAfterUninstall} -function InvalidGetMem(ASize: Integer): Pointer; +function InvalidGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; {$ifndef NoMessageBoxes} var LErrorMessageTitle: array[0..1023] of AnsiChar; @@ -5685,7 +7679,7 @@ function InvalidFreeMem(APointer: Pointer): Integer; Result := -1; end; -function InvalidReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; +function InvalidReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; {$ifndef NoMessageBoxes} var LErrorMessageTitle: array[0..1023] of AnsiChar; @@ -5701,7 +7695,7 @@ function InvalidReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; Result := nil; end; -function InvalidAllocMem(ASize: Cardinal): Pointer; +function InvalidAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer; {$ifndef NoMessageBoxes} var LErrorMessageTitle: array[0..1023] of AnsiChar; @@ -5728,41 +7722,207 @@ function InvalidRegisterAndUnRegisterMemoryLeak(APointer: Pointer): Boolean; {$ifdef FullDebugMode} +{Compare [AAddress], CompareVal: + If Equal: [AAddress] := NewVal and result = CompareVal + If Unequal: Result := [AAddress]} +function LockCmpxchg32(CompareVal, NewVal: Integer; AAddress: PInteger): Integer; +asm +{$ifdef 32Bit} + {On entry: + eax = CompareVal, + edx = NewVal, + ecx = AAddress} + lock cmpxchg [ecx], edx +{$else} +.noframe + {On entry: + ecx = CompareVal, + edx = NewVal, + r8 = AAddress} + mov eax, ecx + lock cmpxchg [r8], edx +{$endif} +end; + +{Called by DebugGetMem, DebugFreeMem and DebugReallocMem in order to block a + free block scan operation while the memory pool is being modified.} +procedure StartChangingFullDebugModeBlock; +var + LOldCount: Integer; +begin + while True do + begin + {Get the old thread count} + LOldCount := ThreadsInFullDebugModeRoutine; + if (LOldCount >= 0) + and (LockCmpxchg32(LOldCount, LOldCount + 1, @ThreadsInFullDebugModeRoutine) = LOldCount) then + begin + Break; + end; + {$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThread; + {$endif} + {$else} + Sleep(InitialSleepTime); + {Try again} + LOldCount := ThreadsInFullDebugModeRoutine; + if (LOldCount >= 0) + and (LockCmpxchg32(LOldCount, LOldCount + 1, @ThreadsInFullDebugModeRoutine) = LOldCount) then + begin + Break; + end; + Sleep(AdditionalSleepTime); + {$endif} + end; +end; + +procedure DoneChangingFullDebugModeBlock; +asm +{$ifdef 32Bit} + lock dec ThreadsInFullDebugModeRoutine +{$else} +.noframe + lea rax, ThreadsInFullDebugModeRoutine + lock dec dword ptr [rax] +{$endif} +end; + +{Increments the allocation number} +procedure IncrementAllocationNumber; +asm +{$ifdef 32Bit} + lock inc CurrentAllocationNumber +{$else} +.noframe + lea rax, CurrentAllocationNumber + lock inc dword ptr [rax] +{$endif} +end; + +{Called by a routine wanting to lock the entire memory pool in FullDebugMode, e.g. before scanning the memory + pool for corruptions.} +procedure BlockFullDebugModeMMRoutines; +begin + while True do + begin + {Get the old thread count} + if LockCmpxchg32(0, -1, @ThreadsInFullDebugModeRoutine) = 0 then + Break; +{$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThread; + {$endif} +{$else} + Sleep(InitialSleepTime); + {Try again} + if LockCmpxchg32(0, -1, @ThreadsInFullDebugModeRoutine) = 0 then + Break; + Sleep(AdditionalSleepTime); +{$endif} + end; +end; + +procedure UnblockFullDebugModeMMRoutines; +begin + {Currently blocked? If so, unblock the FullDebugMode routines.} + if ThreadsInFullDebugModeRoutine = -1 then + ThreadsInFullDebugModeRoutine := 0; +end; + procedure DeleteEventLog; begin {Delete the file} DeleteFileA(MMLogFileName); end; +{Finds the start and length of the file name given a full path.} +procedure ExtractFileName(APFullPath: PAnsiChar; var APFileNameStart: PAnsiChar; var AFileNameLength: Integer); +var + LChar: AnsiChar; +begin + {Initialize} + APFileNameStart := APFullPath; + AFileNameLength := 0; + {Find the file } + while True do + begin + {Get the next character} + LChar := APFullPath^; + {End of the path string?} + if LChar = #0 then + Break; + {Advance the buffer position} + Inc(APFullPath); + {Found a backslash? -> May be the start of the file name} + if LChar = '\' then + APFileNameStart := APFullPath; + end; + {Calculate the length of the file name} + AFileNameLength := IntPtr(APFullPath) - IntPtr(APFileNameStart); +end; + procedure AppendEventLog(ABuffer: Pointer; ACount: Cardinal); +const + {Declared here, because it is not declared in the SHFolder.pas unit of some older Delphi versions.} + SHGFP_TYPE_CURRENT = 0; var LFileHandle, LBytesWritten: Cardinal; LEventHeader: array[0..1023] of AnsiChar; - LMsgPtr: PAnsiChar; + LAlternateLogFileName: array[0..2047] of AnsiChar; + LPathLen, LNameLength: Integer; + LMsgPtr, LPFileName: PAnsiChar; LSystemTime: TSystemTime; begin - {Append the file} + {Try to open the log file in read/write mode.} LFileHandle := CreateFileA(MMLogFileName, GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); - if LFileHandle <> 0 then + {Did log file creation fail? If so, the destination folder is perhaps read-only: + Try to redirect logging to a file in the user's "My Documents" folder.} + if (LFileHandle = INVALID_HANDLE_VALUE) +{$ifdef Delphi4or5} + and SHGetSpecialFolderPathA(0, @LAlternateLogFileName, CSIDL_PERSONAL, True) then +{$else} + and (SHGetFolderPathA(0, CSIDL_PERSONAL or CSIDL_FLAG_CREATE, 0, + SHGFP_TYPE_CURRENT, @LAlternateLogFileName) = S_OK) then +{$endif} + begin + {Extract the filename part from MMLogFileName and append it to the path of + the "My Documents" folder.} + LPathLen := StrLen(LAlternateLogFileName); + {Ensure that there is a trailing backslash in the path} + if (LPathLen = 0) or (LAlternateLogFileName[LPathLen - 1] <> '\') then + begin + LAlternateLogFileName[LPathLen] := '\'; + Inc(LPathLen); + end; + {Add the filename to the path} + ExtractFileName(@MMLogFileName, LPFileName, LNameLength); + System.Move(LPFileName^, LAlternateLogFileName[LPathLen], LNameLength + 1); + {Try to open the alternate log file} + LFileHandle := CreateFileA(LAlternateLogFileName, GENERIC_READ or GENERIC_WRITE, + 0, nil, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); + end; + {Was the log file opened/created successfully?} + if LFileHandle <> INVALID_HANDLE_VALUE then begin {Seek to the end of the file} SetFilePointer(LFileHandle, 0, nil, FILE_END); {Set the separator} - LMsgPtr := AppendStringToBuffer(CRLF, @LEventHeader[0], length(CRLF)); - LMsgPtr := AppendStringToBuffer(EventSeparator, LMsgPtr, length(EventSeparator)); + LMsgPtr := AppendStringToBuffer(CRLF, @LEventHeader[0], Length(CRLF)); + LMsgPtr := AppendStringToBuffer(EventSeparator, LMsgPtr, Length(EventSeparator)); {Set the date & time} GetLocalTime(LSystemTime); - LMsgPtr := CardinalToStrBuf(LSystemTime.wYear, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LSystemTime.wYear, LMsgPtr); LMsgPtr^ := '/'; Inc(LMsgPtr); - LMsgPtr := CardinalToStrBuf(LSystemTime.wMonth, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LSystemTime.wMonth, LMsgPtr); LMsgPtr^ := '/'; Inc(LMsgPtr); - LMsgPtr := CardinalToStrBuf(LSystemTime.wDay, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LSystemTime.wDay, LMsgPtr); LMsgPtr^ := ' '; Inc(LMsgPtr); - LMsgPtr := CardinalToStrBuf(LSystemTime.wHour, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LSystemTime.wHour, LMsgPtr); LMsgPtr^ := ':'; Inc(LMsgPtr); if LSystemTime.wMinute < 10 then @@ -5770,7 +7930,7 @@ procedure AppendEventLog(ABuffer: Pointer; ACount: Cardinal); LMsgPtr^ := '0'; Inc(LMsgPtr); end; - LMsgPtr := CardinalToStrBuf(LSystemTime.wMinute, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LSystemTime.wMinute, LMsgPtr); LMsgPtr^ := ':'; Inc(LMsgPtr); if LSystemTime.wSecond < 10 then @@ -5778,11 +7938,11 @@ procedure AppendEventLog(ABuffer: Pointer; ACount: Cardinal); LMsgPtr^ := '0'; Inc(LMsgPtr); end; - LMsgPtr := CardinalToStrBuf(LSystemTime.WSecond, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LSystemTime.WSecond, LMsgPtr); {Write the header} - LMsgPtr := AppendStringToBuffer(EventSeparator, LMsgPtr, length(EventSeparator)); - LMsgPtr := AppendStringToBuffer(CRLF, LMsgPtr, length(CRLF)); - WriteFile(LFileHandle, LEventHeader[0], Cardinal(LMsgPtr) - Cardinal(@LEventHeader[0]), LBytesWritten, nil); + LMsgPtr := AppendStringToBuffer(EventSeparator, LMsgPtr, Length(EventSeparator)); + LMsgPtr := AppendStringToBuffer(CRLF, LMsgPtr, Length(CRLF)); + WriteFile(LFileHandle, LEventHeader[0], NativeUInt(LMsgPtr) - NativeUInt(@LEventHeader[0]), LBytesWritten, nil); {Write the data} WriteFile(LFileHandle, ABuffer^, ACount, LBytesWritten, nil); {Close the file} @@ -5795,15 +7955,38 @@ procedure SetDefaultMMLogFileName; const LogFileExtAnsi: PAnsiChar = LogFileExtension; var - LModuleNameLength: Cardinal; + LEnvVarLength, LModuleNameLength: Cardinal; + LPathOverride: array[0..2047] of AnsiChar; + LPFileName: PAnsiChar; + LFileNameLength: Integer; begin {Get the name of the application} LModuleNameLength := AppendModuleFileName(@MMLogFileName[0]); - {Replace the last few characters} + {Replace the last few characters of the module name, and optionally override + the path.} if LModuleNameLength > 0 then begin {Change the filename} - System.Move(LogFileExtAnsi^, MMLogFileName[LModuleNameLength - 4], StrLen(LogFileExtAnsi)); + System.Move(LogFileExtAnsi^, MMLogFileName[LModuleNameLength - 4], + StrLen(LogFileExtAnsi) + 1); + {Try to read the FastMMLogFilePath environment variable} + LEnvVarLength := GetEnvironmentVariableA('FastMMLogFilePath', + @LPathOverride, 1023); + {Does the environment variable exist? If so, override the log file path.} + if LEnvVarLength > 0 then + begin + {Ensure that there's a trailing backslash.} + if LPathOverride[LEnvVarLength - 1] <> '\' then + begin + LPathOverride[LEnvVarLength] := '\'; + Inc(LEnvVarLength); + end; + {Add the filename to the path override} + ExtractFileName(@MMLogFileName[0], LPFileName, LFileNameLength); + System.Move(LPFileName^, LPathOverride[LEnvVarLength], LFileNameLength + 1); + {Copy the override path back to the filename buffer} + System.Move(LPathOverride, MMLogFileName, SizeOf(MMLogFileName) - 1); + end; end; end; @@ -5812,20 +7995,21 @@ procedure SetDefaultMMLogFileName; revert to the default log file name.} procedure SetMMLogFileName(ALogFileName: PAnsiChar = nil); var - i: integer; + LLogFileNameLen: Integer; begin + {Is ALogFileName valid?} if (ALogFileName <> nil) and (ALogFileName^ <> #0) then begin - for i := 0 to StrLen(MMLogFileName) - 2 do + LLogFileNameLen := StrLen(ALogFileName); + if LLogFileNameLen < Length(MMLogFileName) then begin - MMLogFileName[i] := ALogFileName^; - if MMlogFileName[i] = #0 then - Break; - Inc(ALogFileName); + {Set the log file name} + System.Move(ALogFileName^, MMLogFileName, LLogFileNameLen + 1); + Exit; end; - end - else - SetDefaultMMLogFileName; + end; + {Invalid log file name} + SetDefaultMMLogFileName; end; {Returns the current "allocation group". Whenever a GetMem request is serviced @@ -5876,9 +8060,12 @@ procedure PopAllocationGroup; end; end; -{Sums all the dwords starting at the given address.} -function SumCardinals(AStartValue: Cardinal; APointer: PCardinal; ACount: Cardinal): Cardinal; +{Sums all the dwords starting at the given address. ACount must be > 0 and a + multiple of SizeOf(Pointer).} +function SumNativeUInts(AStartValue: NativeUInt; APointer: PNativeUInt; + ACount: NativeUInt): NativeUInt; asm +{$ifdef 32Bit} {On entry: eax = AStartValue, edx = APointer; ecx = ACount} add edx, ecx neg ecx @@ -5886,64 +8073,94 @@ function SumCardinals(AStartValue: Cardinal; APointer: PCardinal; ACount: Cardin add eax, [edx + ecx] add ecx, 4 js @AddLoop +{$else} + {On entry: rcx = AStartValue, rdx = APointer; r8 = ACount} + add rdx, r8 + neg r8 + mov rax, rcx +@AddLoop: + add rax, [rdx + r8] + add r8, 8 + js @AddLoop +{$endif} end; -{Sums all the dwords starting at the given address for the fill pattern. - Returns true if they are all valid} -function CheckFillPattern(APointer: PCardinal; ACount: Cardinal): Boolean; +{Checks the memory starting at the given address for the fill pattern. + Returns True if all bytes are all valid. ACount must be >0 and a multiple of + SizeOf(Pointer).} +function CheckFillPattern(APointer: Pointer; ACount: NativeUInt; + AFillPattern: NativeUInt): Boolean; asm - {On entry: eax = APointer; edx = ACount} +{$ifdef 32Bit} + {On entry: eax = APointer; edx = ACount; ecx = AFillPattern} add eax, edx neg edx @CheckLoop: - cmp dword ptr [eax + edx], DebugFillDWord + cmp [eax + edx], ecx + jne @Done + add edx, 4 + js @CheckLoop +@Done: + sete al +{$else} + {On entry: rcx = APointer; rdx = ACount; r8 = AFillPattern} + add rcx, rdx + neg rdx +@CheckLoop: + cmp [rcx + rdx], r8 jne @Done - add edx, 4 + add rdx, 8 js @CheckLoop @Done: sete al +{$endif} end; {Calculates the checksum for the debug header. Adds all dwords in the debug header to the start address of the block.} -function CalculateHeaderCheckSum(APointer: PFullDebugBlockHeader): Cardinal; +function CalculateHeaderCheckSum(APointer: PFullDebugBlockHeader): NativeUInt; begin - Result := SumCardinals(Cardinal(APointer), - PCardinal(Cardinal(APointer) + 8), - SizeOf(TFullDebugBlockHeader) - 8 - 4); + Result := SumNativeUInts( + NativeUInt(APointer), + PNativeUInt(PByte(APointer) + 2 * SizeOf(Pointer)), + SizeOf(TFullDebugBlockHeader) - 2 * SizeOf(Pointer) - SizeOf(NativeUInt)); end; procedure UpdateHeaderAndFooterCheckSums(APointer: PFullDebugBlockHeader); var - LHeaderCheckSum: Cardinal; + LHeaderCheckSum: NativeUInt; begin LHeaderCheckSum := CalculateHeaderCheckSum(APointer); APointer.HeaderCheckSum := LHeaderCheckSum; - PCardinal(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader) + APointer.UserSize)^ := not LHeaderCheckSum; + PNativeUInt(PByte(APointer) + SizeOf(TFullDebugBlockHeader) + APointer.UserSize)^ := not LHeaderCheckSum; end; -function LogCurrentStackTrace(ASkipFrames: Cardinal; ABuffer: PAnsiChar): PAnsiChar; +function LogCurrentThreadAndStackTrace(ASkipFrames: Cardinal; ABuffer: PAnsiChar): PAnsiChar; var LCurrentStackTrace: TStackTrace; begin {Get the current call stack} GetStackTrace(@LCurrentStackTrace[0], StackTraceDepth, ASkipFrames); - {List it} - Result := AppendStringToBuffer(CurrentStackTraceMsg, ABuffer, length(CurrentStackTraceMsg)); + {Log the thread ID} + Result := AppendStringToBuffer(CurrentThreadIDMsg, ABuffer, Length(CurrentThreadIDMsg)); + Result := NativeUIntToHexBuf(GetThreadID, Result); + {List the stack trace} + Result := AppendStringToBuffer(CurrentStackTraceMsg, Result, Length(CurrentStackTraceMsg)); Result := LogStackTrace(@LCurrentStackTrace, StackTraceDepth, Result); end; +{$ifndef DisableLoggingOfMemoryDumps} function LogMemoryDump(APointer: PFullDebugBlockHeader; ABuffer: PAnsiChar): PAnsiChar; var LByteNum, LVal: Cardinal; LDataPtr: PByte; begin Result := AppendStringToBuffer(MemoryDumpMsg, ABuffer, Length(MemoryDumpMsg)); - Result := CardinalToHexBuf(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader), Result); + Result := NativeUIntToHexBuf(NativeUInt(APointer) + SizeOf(TFullDebugBlockHeader), Result); Result^ := ':'; Inc(Result); {Add the bytes} - LDataPtr := PByte(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader)); + LDataPtr := PByte(PByte(APointer) + SizeOf(TFullDebugBlockHeader)); for LByteNum := 0 to 255 do begin if LByteNum and 31 = 0 then @@ -5959,7 +8176,7 @@ function LogMemoryDump(APointer: PFullDebugBlockHeader; ABuffer: PAnsiChar): PAn Inc(Result); end; {Set the hex data} - LVal := LDataPtr^; + LVal := Byte(LDataPtr^); Result^ := HexTable[LVal shr 4]; Inc(Result); Result^ := HexTable[LVal and $f]; @@ -5968,7 +8185,7 @@ function LogMemoryDump(APointer: PFullDebugBlockHeader; ABuffer: PAnsiChar): PAn Inc(LDataPtr); end; {Dump ASCII} - LDataPtr := PByte(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader)); + LDataPtr := PByte(PByte(APointer) + SizeOf(TFullDebugBlockHeader)); for LByteNum := 0 to 255 do begin if LByteNum and 31 = 0 then @@ -5986,7 +8203,7 @@ function LogMemoryDump(APointer: PFullDebugBlockHeader; ABuffer: PAnsiChar): PAn Inc(Result); end; {Set the hex data} - LVal := LDataPtr^; + LVal := Byte(LDataPtr^); if LVal < 32 then Result^ := '.' else @@ -5996,6 +8213,99 @@ function LogMemoryDump(APointer: PFullDebugBlockHeader; ABuffer: PAnsiChar): PAn Inc(LDataPtr); end; end; +{$endif} + +{Rotates AValue ABitCount bits to the right} +function RotateRight(AValue, ABitCount: NativeUInt): NativeUInt; +asm +{$ifdef 32Bit} + mov ecx, edx + ror eax, cl +{$else} + mov rax, rcx + mov rcx, rdx + ror rax, cl +{$endif} +end; + +{Determines whether a byte in the user portion of the freed block has been modified. Does not work beyond + the end of the user portion (i.e. footer and beyond).} +function FreeBlockByteWasModified(APointer: PFullDebugBlockHeader; AUserOffset: NativeUInt): Boolean; +var + LFillPattern: NativeUInt; +begin + {Get the expected fill pattern} + if AUserOffset < SizeOf(Pointer) then + begin + LFillPattern := NativeUInt(@FreedObjectVMT.VMTMethods[0]); + end + else + begin +{$ifndef CatchUseOfFreedInterfaces} + LFillPattern := DebugFillPattern; +{$else} + LFillPattern := NativeUInt(@VMTBadInterface); +{$endif} + end; + {Compare the byte value} + Result := Byte(PByte(PByte(APointer) + SizeOf(TFullDebugBlockHeader) + AUserOffset)^) <> + Byte(RotateRight(LFillPattern, (AUserOffset and (SizeOf(Pointer) - 1)) * 8)); +end; + +function LogBlockChanges(APointer: PFullDebugBlockHeader; ABuffer: PAnsiChar): PAnsiChar; +var + LOffset, LChangeStart, LCount: NativeUInt; + LLogCount: Integer; +begin + {No errors logged so far} + LLogCount := 0; + {Log a maximum of 32 changes} + LOffset := 0; + while (LOffset < APointer.UserSize) and (LLogCount < 32) do + begin + {Has the byte been modified?} + if FreeBlockByteWasModified(APointer, LOffset) then + begin + {Found the start of a changed block, now find the length} + LChangeStart := LOffset; + LCount := 0; + while True do + begin + Inc(LCount); + Inc(LOffset); + if (LOffset >= APointer.UserSize) + or (not FreeBlockByteWasModified(APointer, LOffset)) then + begin + Break; + end; + end; + {Got the offset and length, now log it.} + if LLogCount = 0 then + begin + ABuffer := AppendStringToBuffer(FreeModifiedDetailMsg, ABuffer, Length(FreeModifiedDetailMsg)); + end + else + begin + ABuffer^ := ','; + Inc(ABuffer); + ABuffer^ := ' '; + Inc(ABuffer); + end; + ABuffer := NativeUIntToStrBuf(LChangeStart, ABuffer); + ABuffer^ := '('; + Inc(ABuffer); + ABuffer := NativeUIntToStrBuf(LCount, ABuffer); + ABuffer^ := ')'; + Inc(ABuffer); + {Increment the log count} + Inc(LLogCount); + end; + {Next byte} + Inc(LOffset); + end; + {Return the current buffer position} + Result := ABuffer; +end; procedure LogBlockError(APointer: PFullDebugBlockHeader; AOperation: TBlockOperation; LHeaderValid, LFooterValid: Boolean); var @@ -6024,11 +8334,24 @@ procedure LogBlockError(APointer: PFullDebugBlockHeader; AOperation: TBlockOpera {Is the footer still valid?} if LFooterValid then begin - {A freed block has been modified, or a double free has occurred} + {A freed block has been modified, a double free has occurred, or an + attempt was made to free a memory block allocated by a different + instance of FastMM.} if AOperation <= boGetMem then - LMsgPtr := AppendStringToBuffer(FreeModifiedErrorMsg, LMsgPtr, Length(FreeModifiedErrorMsg)) + begin + LMsgPtr := AppendStringToBuffer(FreeModifiedErrorMsg, LMsgPtr, Length(FreeModifiedErrorMsg)); + {Log the exact changes that caused the error.} + LMsgPtr := LogBlockChanges(APointer, LMsgPtr); + end else - LMsgPtr := AppendStringToBuffer(DoubleFreeErrorMsg, LMsgPtr, Length(DoubleFreeErrorMsg)); + begin + {It is either a double free, or an attempt was made to free a block + that was allocated via a different memory manager.} + if APointer.AllocatedByRoutine = nil then + LMsgPtr := AppendStringToBuffer(DoubleFreeErrorMsg, LMsgPtr, Length(DoubleFreeErrorMsg)) + else + LMsgPtr := AppendStringToBuffer(WrongMMFreeErrorMsg, LMsgPtr, Length(WrongMMFreeErrorMsg)); + end; end else begin @@ -6039,19 +8362,21 @@ procedure LogBlockError(APointer: PFullDebugBlockHeader; AOperation: TBlockOpera LMsgPtr := AppendStringToBuffer(PreviousBlockSizeMsg, LMsgPtr, Length(PreviousBlockSizeMsg)) else LMsgPtr := AppendStringToBuffer(CurrentBlockSizeMsg, LMsgPtr, Length(CurrentBlockSizeMsg)); - LMsgPtr := CardinalToStrBuf(APointer.UserSize, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(APointer.UserSize, LMsgPtr); {The header is still intact - display info about the this/previous allocation} if APointer.AllocationStackTrace[0] <> 0 then begin if AOperation <= boGetMem then - LMsgPtr := AppendStringToBuffer(StackTraceAtPrevAllocMsg, LMsgPtr, Length(StackTraceAtPrevAllocMsg)) + LMsgPtr := AppendStringToBuffer(ThreadIDPrevAllocMsg, LMsgPtr, Length(ThreadIDPrevAllocMsg)) else - LMsgPtr := AppendStringToBuffer(StackTraceAtAllocMsg, LMsgPtr, Length(StackTraceAtAllocMsg)); + LMsgPtr := AppendStringToBuffer(ThreadIDAtAllocMsg, LMsgPtr, Length(ThreadIDAtAllocMsg)); + LMsgPtr := NativeUIntToHexBuf(APointer.AllocatedByThread, LMsgPtr); + LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg)); LMsgPtr := LogStackTrace(@APointer.AllocationStackTrace, StackTraceDepth, LMsgPtr); end; {Get the class this block was used for previously} - LClass := GetObjectClass(@APointer.PreviouslyUsedByClass); - if (LClass <> nil) and (Cardinal(LClass) <> Cardinal(@FreedObjectVMT.VMTMethods[0])) then + LClass := DetectClassInstance(@APointer.PreviouslyUsedByClass); + if (LClass <> nil) and (IntPtr(LClass) <> IntPtr(@FreedObjectVMT.VMTMethods[0])) then begin LMsgPtr := AppendStringToBuffer(PreviousObjectClassMsg, LMsgPtr, Length(PreviousObjectClassMsg)); LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr); @@ -6068,18 +8393,18 @@ procedure LogBlockError(APointer: PFullDebugBlockHeader; AOperation: TBlockOpera end; {$endif} {Get the current class for this block} - if (AOperation > boGetMem) and (not LFooterValid) then + if (AOperation > boGetMem) and (APointer.AllocatedByRoutine <> nil) then begin LMsgPtr := AppendStringToBuffer(CurrentObjectClassMsg, LMsgPtr, Length(CurrentObjectClassMsg)); - LClass := GetObjectClass(Pointer(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader))); - if Cardinal(LClass) = Cardinal(@FreedObjectVMT.VMTMethods[0]) then + LClass := DetectClassInstance(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader))); + if IntPtr(LClass) = IntPtr(@FreedObjectVMT.VMTMethods[0]) then LClass := nil; {$ifndef CheckCppObjectTypeEnabled} LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr); {$else} if (LClass = nil) and Assigned(GetCppVirtObjTypeNameFunc) then begin - LCppObjectTypeName := GetCppVirtObjTypeNameFunc(Pointer(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader)), + LCppObjectTypeName := GetCppVirtObjTypeNameFunc(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)), APointer.UserSize); if LCppObjectTypeName <> nil then LMsgPtr := AppendStringToBuffer(LCppObjectTypeName, LMsgPtr, StrLen(LCppObjectTypeName)) @@ -6095,11 +8420,11 @@ procedure LogBlockError(APointer: PFullDebugBlockHeader; AOperation: TBlockOpera if APointer.AllocationGroup > 0 then begin LMsgPtr := AppendStringToBuffer(CurrentAllocationGroupMsg, LMsgPtr, Length(CurrentAllocationGroupMsg)); - LMsgPtr := CardinalToStrBuf(APointer.AllocationGroup, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(APointer.AllocationGroup, LMsgPtr); end; {Log the allocation number} LMsgPtr := AppendStringToBuffer(CurrentAllocationNumberMsg, LMsgPtr, Length(CurrentAllocationNumberMsg)); - LMsgPtr := CardinalToStrBuf(APointer.AllocationNumber, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(APointer.AllocationNumber, LMsgPtr); end else begin @@ -6107,16 +8432,18 @@ procedure LogBlockError(APointer: PFullDebugBlockHeader; AOperation: TBlockOpera if APointer.AllocationGroup > 0 then begin LMsgPtr := AppendStringToBuffer(PreviousAllocationGroupMsg, LMsgPtr, Length(PreviousAllocationGroupMsg)); - LMsgPtr := CardinalToStrBuf(APointer.AllocationGroup, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(APointer.AllocationGroup, LMsgPtr); end; {Log the allocation number} LMsgPtr := AppendStringToBuffer(PreviousAllocationNumberMsg, LMsgPtr, Length(PreviousAllocationNumberMsg)); - LMsgPtr := CardinalToStrBuf(APointer.AllocationNumber, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(APointer.AllocationNumber, LMsgPtr); end; {Get the call stack for the previous free} if APointer.FreeStackTrace[0] <> 0 then begin - LMsgPtr := AppendStringToBuffer(StackTraceAtFreeMsg, LMsgPtr, Length(StackTraceAtFreeMsg)); + LMsgPtr := AppendStringToBuffer(ThreadIDAtFreeMsg, LMsgPtr, Length(ThreadIDAtFreeMsg)); + LMsgPtr := NativeUIntToHexBuf(APointer.FreedByThread, LMsgPtr); + LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg)); LMsgPtr := LogStackTrace(@APointer.FreeStackTrace, StackTraceDepth, LMsgPtr); end; end @@ -6126,9 +8453,11 @@ procedure LogBlockError(APointer: PFullDebugBlockHeader; AOperation: TBlockOpera LMsgPtr := AppendStringToBuffer(BlockHeaderCorruptedMsg, LMsgPtr, Length(BlockHeaderCorruptedMsg)); end; {Add the current stack trace} - LMsgPtr := LogCurrentStackTrace(3 + ord(AOperation <> boGetMem) + ord(AOperation = boReallocMem), LMsgPtr); + LMsgPtr := LogCurrentThreadAndStackTrace(3 + Ord(AOperation <> boGetMem) + Ord(AOperation = boReallocMem), LMsgPtr); +{$ifndef DisableLoggingOfMemoryDumps} {Add the memory dump} LMsgPtr := LogMemoryDump(APointer, LMsgPtr); +{$endif} {Trailing CRLF} LMsgPtr^ := #13; Inc(LMsgPtr); @@ -6138,7 +8467,7 @@ procedure LogBlockError(APointer: PFullDebugBlockHeader; AOperation: TBlockOpera LMsgPtr^ := #0; {$ifdef LogErrorsToFile} {Log the error} - AppendEventLog(@LErrorMessage[0], Cardinal(LMsgPtr) - Cardinal(@LErrorMessage[0])); + AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0])); {$endif} {$ifdef UseOutputDebugString} OutputDebugStringA(LErrorMessage); @@ -6166,7 +8495,7 @@ procedure LogMemoryLeakOrAllocatedBlock(APointer: PFullDebugBlockHeader; IsALeak LMsgPtr := AppendStringToBuffer(LeakLogHeader, @LErrorMessage[0], Length(LeakLogHeader)) else LMsgPtr := AppendStringToBuffer(BlockScanLogHeader, @LErrorMessage[0], Length(BlockScanLogHeader)); - LMsgPtr := CardinalToStrBuf(GetAvailableSpaceInBlock(APointer) - FullDebugBlockOverhead, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(GetAvailableSpaceInBlock(APointer) - FullDebugBlockOverhead, LMsgPtr); {Is the debug info surrounding the block valid?} LHeaderValid := CalculateHeaderCheckSum(APointer) = APointer.HeaderCheckSum; {Is the header still intact?} @@ -6175,36 +8504,57 @@ procedure LogMemoryLeakOrAllocatedBlock(APointer: PFullDebugBlockHeader; IsALeak {The header is still intact - display info about this/previous allocation} if APointer.AllocationStackTrace[0] <> 0 then begin - LMsgPtr := AppendStringToBuffer(StackTraceAtAllocMsg, LMsgPtr, Length(StackTraceAtAllocMsg)); + LMsgPtr := AppendStringToBuffer(ThreadIDAtAllocMsg, LMsgPtr, Length(ThreadIDAtAllocMsg)); + LMsgPtr := NativeUIntToHexBuf(APointer.AllocatedByThread, LMsgPtr); + LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg)); LMsgPtr := LogStackTrace(@APointer.AllocationStackTrace, StackTraceDepth, LMsgPtr); end; LMsgPtr := AppendStringToBuffer(CurrentObjectClassMsg, LMsgPtr, Length(CurrentObjectClassMsg)); {Get the current class for this block} - LClass := GetObjectClass(Pointer(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader))); - if Cardinal(LClass) = Cardinal(@FreedObjectVMT.VMTMethods[0]) then + LClass := DetectClassInstance(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader))); + if IntPtr(LClass) = IntPtr(@FreedObjectVMT.VMTMethods[0]) then LClass := nil; {$ifndef CheckCppObjectTypeEnabled} - LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr); + if LClass <> nil then + begin + LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr); + end + else + begin + case DetectStringData(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)), APointer.UserSize) of + stUnknown: LMsgPtr := AppendClassNameToBuffer(nil, LMsgPtr); + stAnsiString: LMsgPtr := AppendStringToBuffer(AnsiStringBlockMessage, LMsgPtr, Length(AnsiStringBlockMessage)); + stUnicodeString: LMsgPtr := AppendStringToBuffer(UnicodeStringBlockMessage, LMsgPtr, Length(UnicodeStringBlockMessage)); + end; + end; {$else} if (LClass = nil) and Assigned(GetCppVirtObjTypeNameFunc) then begin - LCppObjectTypeName := GetCppVirtObjTypeNameFunc(Pointer(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader)), + LCppObjectTypeName := GetCppVirtObjTypeNameFunc(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)), APointer.UserSize); if LCppObjectTypeName <> nil then LMsgPtr := AppendStringToBuffer(LCppObjectTypeName, LMsgPtr, StrLen(LCppObjectTypeName)) else - LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr); - end; + begin + case DetectStringData(Pointer(PByte(APointer) + SizeOf(TFullDebugBlockHeader)), APointer.UserSize) of + stUnknown: LMsgPtr := AppendClassNameToBuffer(nil, LMsgPtr); + stAnsiString: LMsgPtr := AppendStringToBuffer(AnsiStringBlockMessage, LMsgPtr, Length(AnsiStringBlockMessage)); + stUnicodeString: LMsgPtr := AppendStringToBuffer(UnicodeStringBlockMessage, LMsgPtr, Length(UnicodeStringBlockMessage)); + end; + end; + end + else + LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr); {$endif} {Log the allocation group} if APointer.AllocationGroup > 0 then begin LMsgPtr := AppendStringToBuffer(CurrentAllocationGroupMsg, LMsgPtr, Length(CurrentAllocationGroupMsg)); - LMsgPtr := CardinalToStrBuf(APointer.AllocationGroup, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(APointer.AllocationGroup, LMsgPtr); end; {Log the allocation number} LMsgPtr := AppendStringToBuffer(CurrentAllocationNumberMsg, LMsgPtr, Length(CurrentAllocationNumberMsg)); - LMsgPtr := CardinalToStrBuf(APointer.AllocationNumber, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(APointer.AllocationNumber, LMsgPtr); end else begin @@ -6215,8 +8565,10 @@ procedure LogMemoryLeakOrAllocatedBlock(APointer: PFullDebugBlockHeader; IsALeak Inc(LMsgPtr); LMsgPtr := AppendStringToBuffer(BlockHeaderCorruptedMsg, LMsgPtr, Length(BlockHeaderCorruptedMsg)); end; +{$ifndef DisableLoggingOfMemoryDumps} {Add the memory dump} LMsgPtr := LogMemoryDump(APointer, LMsgPtr); +{$endif} {Trailing CRLF} LMsgPtr^ := #13; Inc(LMsgPtr); @@ -6225,36 +8577,44 @@ procedure LogMemoryLeakOrAllocatedBlock(APointer: PFullDebugBlockHeader; IsALeak {Trailing #0} LMsgPtr^ := #0; {Log the error} - AppendEventLog(@LErrorMessage[0], Cardinal(LMsgPtr) - Cardinal(@LErrorMessage[0])); + AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0])); end; {Checks that a free block is unmodified} -function CheckFreeBlockUnmodified(APBlock: PFullDebugBlockHeader; ABlockSize: Cardinal; +function CheckFreeBlockUnmodified(APBlock: PFullDebugBlockHeader; ABlockSize: NativeUInt; AOperation: TBlockOperation): Boolean; var - LHeaderCheckSum: Cardinal; - LHeaderValid, LFooterValid{$ifndef CatchUseOfFreedInterfaces}, LBlockUnmodified{$endif}: Boolean; + LHeaderCheckSum: NativeUInt; + LHeaderValid, LFooterValid, LBlockUnmodified: Boolean; begin LHeaderCheckSum := CalculateHeaderCheckSum(APBlock); - LHeaderValid := LHeaderCheckSum = PFullDebugBlockHeader(APBlock).HeaderCheckSum; + LHeaderValid := LHeaderCheckSum = APBlock.HeaderCheckSum; {Is the footer itself still in place} LFooterValid := LHeaderValid - and (PCardinal(Cardinal(APBlock) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(APBlock).UserSize)^ = (not LHeaderCheckSum)); -{$ifndef CatchUseOfFreedInterfaces} - if LFooterValid then + and (PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + APBlock.UserSize)^ = (not LHeaderCheckSum)); + {Is the footer and debug VMT in place? The debug VMT is only valid if the user size is greater than the size of a pointer.} + if LFooterValid + and (APBlock.UserSize < SizeOf(Pointer)) or (PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader))^ = NativeUInt(@FreedObjectVMT.VMTMethods[0])) then begin - {Clear the old footer} - PCardinal(Cardinal(APBlock) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(APBlock).UserSize)^ := DebugFillDWord; - {Check that all the filler bytes are valid inside the block, except for the four byte "dummy" class header} - LBlockUnmodified := CheckFillPattern(PCardinal(Cardinal(APBlock) + SizeOf(TFullDebugBlockHeader) + 4), - ABlockSize - (BlockHeaderSize + FullDebugBlockOverhead)); + {Store the debug fill pattern in place of the footer in order to simplify + checking for block modifications.} + PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + APBlock.UserSize)^ := + {$ifndef CatchUseOfFreedInterfaces} + DebugFillPattern; + {$else} + RotateRight(NativeUInt(@VMTBadInterface), (APBlock.UserSize and (SizeOf(Pointer) - 1)) * 8); + {$endif} + {Check that all the filler bytes are valid inside the block, except for + the "dummy" class header} + LBlockUnmodified := CheckFillPattern(PNativeUInt(PByte(APBlock) + (SizeOf(TFullDebugBlockHeader) + SizeOf(Pointer))), + ABlockSize - (FullDebugBlockOverhead + SizeOf(Pointer)), + {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif}); {Reset the old footer} - PCardinal(Cardinal(APBlock) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(APBlock).UserSize)^ := not LHeaderCheckSum; + PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + APBlock.UserSize)^ := not LHeaderCheckSum; end else LBlockUnmodified := False; - {$endif} - if (not LHeaderValid) or (not LFooterValid){$ifndef CatchUseOfFreedInterfaces}or (not LBlockUnmodified){$endif} then + if (not LHeaderValid) or (not LFooterValid) or (not LBlockUnmodified) then begin LogBlockError(APBlock, AOperation, LHeaderValid, LFooterValid); Result := False; @@ -6263,59 +8623,126 @@ function CheckFreeBlockUnmodified(APBlock: PFullDebugBlockHeader; ABlockSize: Ca Result := True; end; -function DebugGetMem(ASize: Integer): Pointer; +function DebugGetMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; begin {Scan the entire memory pool first?} if FullDebugModeScanMemoryPoolBeforeEveryOperation then ScanMemoryPoolForCorruptions; - {We need extra space for (a) The debug header, (b) the block debug trailer - and (c) the trailing block size pointer for free blocks} - Result := FastGetMem(ASize + FullDebugBlockOverhead); - if Result <> nil then - begin - if CheckFreeBlockUnmodified(Result, GetAvailableSpaceInBlock(Result) + 4, boGetMem) then - begin - {Set the allocation call stack} - GetStackTrace(@PFullDebugBlockHeader(Result).AllocationStackTrace, StackTraceDepth, 1); - {Block is now in use} - PFullDebugBlockHeader(Result).BlockInUse := True; - {Set the group number} - PFullDebugBlockHeader(Result).AllocationGroup := AllocationGroupStack[AllocationGroupStackTop]; - {Set the allocation number} - Inc(CurrentAllocationNumber); - PFullDebugBlockHeader(Result).AllocationNumber := CurrentAllocationNumber; - {Clear the previous block trailer} - PCardinal(Cardinal(Result) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(Result).UserSize)^ := DebugFillDWord; - {Set the user size for the block} - PFullDebugBlockHeader(Result).UserSize := ASize; - {Set the checksums} - UpdateHeaderAndFooterCheckSums(Result); - {Return the start of the actual block} - Result := Pointer(Cardinal(Result) + SizeOf(TFullDebugBlockHeader)); - end - else + {Enter the memory manager: block scans may not be performed now} + StartChangingFullDebugModeBlock; + try + {We need extra space for (a) The debug header, (b) the block debug trailer + and (c) the trailing block size pointer for free blocks} + Result := FastGetMem(ASize + FullDebugBlockOverhead); + if Result <> nil then begin - Result := nil; + {Large blocks are always newly allocated (and never reused), so checking + for a modify-after-free is not necessary.} + if (ASize > (MaximumMediumBlockSize - BlockHeaderSize - FullDebugBlockOverhead)) + or CheckFreeBlockUnmodified(Result, GetAvailableSpaceInBlock(Result) + BlockHeaderSize, boGetMem) then + begin + {Set the allocation call stack} + GetStackTrace(@PFullDebugBlockHeader(Result).AllocationStackTrace, StackTraceDepth, 1); + {Set the thread ID of the thread that allocated the block} + PFullDebugBlockHeader(Result).AllocatedByThread := GetThreadID; + {Block is now in use: It was allocated by this routine} + PFullDebugBlockHeader(Result).AllocatedByRoutine := @DebugGetMem; + {Set the group number} + PFullDebugBlockHeader(Result).AllocationGroup := AllocationGroupStack[AllocationGroupStackTop]; + {Set the allocation number} + IncrementAllocationNumber; + PFullDebugBlockHeader(Result).AllocationNumber := CurrentAllocationNumber; + {Clear the previous block trailer} + PNativeUInt(PByte(Result) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(Result).UserSize)^ := + {$ifndef CatchUseOfFreedInterfaces} + DebugFillPattern; + {$else} + RotateRight(NativeUInt(@VMTBadInterface), (PFullDebugBlockHeader(Result).UserSize and (SizeOf(Pointer) - 1)) * 8); + {$endif} + {Set the user size for the block} + PFullDebugBlockHeader(Result).UserSize := ASize; + {Set the checksums} + UpdateHeaderAndFooterCheckSums(Result); + {$ifdef FullDebugModeCallBacks} + if Assigned(OnDebugGetMemFinish) then + OnDebugGetMemFinish(PFullDebugBlockHeader(Result), ASize); + {$endif} + {Return the start of the actual block} + Result := Pointer(PByte(Result) + SizeOf(TFullDebugBlockHeader)); + {Should this block be marked as an expected leak automatically?} + if FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak then + RegisterExpectedMemoryLeak(Result); + end + else + begin + Result := nil; + end; end; + finally + {Leaving the memory manager routine: Block scans may be performed again.} + DoneChangingFullDebugModeBlock; end; end; -function CheckBlockBeforeFreeOrRealloc(APointer: PFullDebugBlockHeader; AOperation: TBlockOperation): Boolean; +function CheckBlockBeforeFreeOrRealloc(APBlock: PFullDebugBlockHeader; + AOperation: TBlockOperation): Boolean; var LHeaderValid, LFooterValid: Boolean; + LPFooter: PNativeUInt; +{$ifndef CatchUseOfFreedInterfaces} + LBlockSize: NativeUInt; + LPTrailingByte, LPFillPatternEnd: PByte; +{$endif} begin - {Is the debug info surrounding the block valid?} - LHeaderValid := CalculateHeaderCheckSum(APointer) = APointer.HeaderCheckSum; - LFooterValid := LHeaderValid - and (APointer.HeaderCheckSum = (not PCardinal(Cardinal(APointer) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(APointer).UserSize)^)); - if LHeaderValid and LFooterValid and APointer.BlockInUse then + {Is the checksum for the block header valid?} + LHeaderValid := CalculateHeaderCheckSum(APBlock) = APBlock.HeaderCheckSum; + {If the header is corrupted then the footer is assumed to be corrupt too.} + if LHeaderValid then + begin + {Check the footer checksum: The footer checksum should equal the header + checksum with all bits inverted.} + LPFooter := PNativeUInt(PByte(APBlock) + SizeOf(TFullDebugBlockHeader) + PFullDebugBlockHeader(APBlock).UserSize); + if APBlock.HeaderCheckSum = (not (LPFooter^)) then + begin + LFooterValid := True; +{$ifndef CatchUseOfFreedInterfaces} + {Large blocks do not have the debug fill pattern, since they are never reused.} + if PNativeUInt(PByte(APBlock) - BlockHeaderSize)^ and (IsMediumBlockFlag or IsLargeBlockFlag) <> IsLargeBlockFlag then + begin + {Check that the application has not modified bytes beyond the block + footer. The $80 fill pattern should extend up to 2 nativeints before + the start of the next block (leaving space for the free block size and + next block header.)} + LBlockSize := GetAvailableSpaceInBlock(APBlock); + LPFillPatternEnd := PByte(PByte(APBlock) + LBlockSize - SizeOf(Pointer)); + LPTrailingByte := PByte(PByte(LPFooter) + SizeOf(NativeUInt)); + while UIntPtr(LPTrailingByte) < UIntPtr(LPFillPatternEnd) do + begin + if Byte(LPTrailingByte^) <> DebugFillByte then + begin + LFooterValid := False; + Break; + end; + Inc(LPTrailingByte); + end; + end; +{$endif} + end + else + LFooterValid := False; + end + else + LFooterValid := False; + {The header and footer must be intact and the block must have been allocated + by this memory manager instance.} + if LFooterValid and (APBlock.AllocatedByRoutine = @DebugGetMem) then begin Result := True; end else begin {Log the error} - LogBlockError(APointer, AOperation, LHeaderValid, LFooterValid); + LogBlockError(APBlock, AOperation, LHeaderValid, LFooterValid); {Return an error} Result := False; end; @@ -6324,50 +8751,80 @@ function CheckBlockBeforeFreeOrRealloc(APointer: PFullDebugBlockHeader; AOperati function DebugFreeMem(APointer: Pointer): Integer; var LActualBlock: PFullDebugBlockHeader; + LBlockHeader: NativeUInt; begin {Scan the entire memory pool first?} if FullDebugModeScanMemoryPoolBeforeEveryOperation then ScanMemoryPoolForCorruptions; {Get a pointer to the start of the actual block} - LActualBlock := PFullDebugBlockHeader(Cardinal(APointer) + LActualBlock := PFullDebugBlockHeader(PByte(APointer) - SizeOf(TFullDebugBlockHeader)); {Is the debug info surrounding the block valid?} if CheckBlockBeforeFreeOrRealloc(LActualBlock, boFreeMem) then begin - {Get the class the block was used for} - LActualBlock.PreviouslyUsedByClass := PCardinal(APointer)^; - {Set the free call stack} - GetStackTrace(@LActualBlock.FreeStackTrace, StackTraceDepth, 1); - {Block is now free} - LActualBlock.BlockInUse := False; - {Clear the user area of the block} - FillDWord(APointer^, LActualBlock.UserSize, - {$ifndef CatchUseOfFreedInterfaces}DebugFillDWord{$else}Cardinal(@VMTBadInterface){$endif}); - {Set a pointer to the dummy VMT} - PCardinal(APointer)^ := Cardinal(@FreedObjectVMT.VMTMethods[0]); - {Recalculate the checksums} - UpdateHeaderAndFooterCheckSums(LActualBlock); - {Free the actual block} - Result := FastFreeMem(LActualBlock); + {Enter the memory manager: block scans may not be performed now} + StartChangingFullDebugModeBlock; + try + {$ifdef FullDebugModeCallBacks} + if Assigned(OnDebugFreeMemStart) then + OnDebugFreeMemStart(LActualBlock); + {$endif} + {Large blocks are never reused, so there is no point in updating their + headers and fill pattern.} + LBlockHeader := PNativeUInt(PByte(LActualBlock) - BlockHeaderSize)^; + if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) <> IsLargeBlockFlag then + begin + {Get the class the block was used for} + LActualBlock.PreviouslyUsedByClass := PNativeUInt(APointer)^; + {Set the free call stack} + GetStackTrace(@LActualBlock.FreeStackTrace, StackTraceDepth, 1); + {Set the thread ID of the thread that freed the block} + LActualBlock.FreedByThread := GetThreadID; + {Block is now free} + LActualBlock.AllocatedByRoutine := nil; + {Clear the user area of the block} + DebugFillMem(APointer^, LActualBlock.UserSize, + {$ifndef CatchUseOfFreedInterfaces}DebugFillPattern{$else}NativeUInt(@VMTBadInterface){$endif}); + {Set a pointer to the dummy VMT} + PNativeUInt(APointer)^ := NativeUInt(@FreedObjectVMT.VMTMethods[0]); + {Recalculate the checksums} + UpdateHeaderAndFooterCheckSums(LActualBlock); + end; + {Automatically deregister the expected memory leak?} + if FullDebugModeRegisterAllAllocsAsExpectedMemoryLeak then + UnregisterExpectedMemoryLeak(APointer); + {Free the actual block} + Result := FastFreeMem(LActualBlock); + {$ifdef FullDebugModeCallBacks} + if Assigned(OnDebugFreeMemFinish) then + OnDebugFreeMemFinish(LActualBlock, Result); + {$endif} + finally + {Leaving the memory manager routine: Block scans may be performed again.} + DoneChangingFullDebugModeBlock; + end; end else begin - Result := -1; +{$ifdef SuppressFreeMemErrorsInsideException} + if {$ifdef BDS2006AndUp}ExceptObject{$else}RaiseList{$endif} <> nil then + Result := 0 + else +{$endif} + Result := -1; end; end; -{In debug mode we never do an in-place resize, data is always moved. This - increases the likelihood of catching memory overwrite bugs.} -function DebugReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; +function DebugReallocMem(APointer: Pointer; ANewSize: {$ifdef XE2AndUp}NativeInt{$else}Integer{$endif}): Pointer; var - LMoveSize, LBlockSpace: Cardinal; + LMoveSize, LBlockSpace: NativeUInt; LActualBlock, LNewActualBlock: PFullDebugBlockHeader; begin {Scan the entire memory pool first?} if FullDebugModeScanMemoryPoolBeforeEveryOperation then ScanMemoryPoolForCorruptions; {Get a pointer to the start of the actual block} - LActualBlock := PFullDebugBlockHeader(Cardinal(APointer) + LActualBlock := PFullDebugBlockHeader(PByte(APointer) - SizeOf(TFullDebugBlockHeader)); {Is the debug info surrounding the block valid?} if CheckBlockBeforeFreeOrRealloc(LActualBlock, boReallocMem) then @@ -6376,28 +8833,42 @@ function DebugReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; LBlockSpace := GetAvailableSpaceInBlock(LActualBlock); {Can the block fit? We need space for the debug overhead and the block header of the next block} - if LBlockSpace < (Cardinal(ANewSize) + FullDebugBlockOverhead) then + if LBlockSpace < (NativeUInt(ANewSize) + FullDebugBlockOverhead) then begin - {Get a new block of the requested size} + {Get a new block of the requested size.} Result := DebugGetMem(ANewSize); if Result <> nil then begin + {Block scans may not be performed now} + StartChangingFullDebugModeBlock; + try + {$ifdef FullDebugModeCallBacks} + if Assigned(OnDebugReallocMemStart) then + OnDebugReallocMemStart(LActualBlock, ANewSize); + {$endif} + {We reuse the old allocation number. Since DebugGetMem always bumps + CurrentAllocationGroup, there may be gaps in the sequence of + allocation numbers.} + LNewActualBlock := PFullDebugBlockHeader(PByte(Result) + - SizeOf(TFullDebugBlockHeader)); + LNewActualBlock.AllocationGroup := LActualBlock.AllocationGroup; + LNewActualBlock.AllocationNumber := LActualBlock.AllocationNumber; + {Recalculate the header and footer checksums} + UpdateHeaderAndFooterCheckSums(LNewActualBlock); + {$ifdef FullDebugModeCallBacks} + if Assigned(OnDebugReallocMemFinish) then + OnDebugReallocMemFinish(LNewActualBlock, ANewSize); + {$endif} + finally + {Block scans can again be performed safely} + DoneChangingFullDebugModeBlock; + end; {How many bytes to move?} LMoveSize := LActualBlock.UserSize; - if LMoveSize > Cardinal(ANewSize) then + if LMoveSize > NativeUInt(ANewSize) then LMoveSize := ANewSize; {Move the data across} System.Move(APointer^, Result^, LMoveSize); - {Keep the old group and allocation numbers} - LNewActualBlock := PFullDebugBlockHeader(Cardinal(Result) - - SizeOf(TFullDebugBlockHeader)); - LNewActualBlock.AllocationGroup := LActualBlock.AllocationGroup; - LNewActualBlock.AllocationNumber := LActualBlock.AllocationNumber; - {This was not a new allocation number - decrement the allocation number - that was incremented in the DebugGetMem call} - Dec(CurrentAllocationNumber); - {Recalculate the header and footer checksums} - UpdateHeaderAndFooterCheckSums(LNewActualBlock); {Free the old block} DebugFreeMem(APointer); end @@ -6408,15 +8879,34 @@ function DebugReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; end else begin - {Clear all data after the new end of the block up to the old end of the - block, including the trailer} - FillDWord(Pointer(Cardinal(APointer) + Cardinal(ANewSize) + 4)^, - Integer(LActualBlock.UserSize) - ANewSize, - {$ifndef CatchUseOfFreedInterfaces}DebugFillDWord{$else}Cardinal(@VMTBadInterface){$endif}); - {Update the user size} - LActualBlock.UserSize := ANewSize; - {Set the new checksums} - UpdateHeaderAndFooterCheckSums(LActualBlock); + {Block scans may not be performed now} + StartChangingFullDebugModeBlock; + try + {$ifdef FullDebugModeCallBacks} + if Assigned(OnDebugReallocMemStart) then + OnDebugReallocMemStart(LActualBlock, ANewSize); + {$endif} + {Clear all data after the new end of the block up to the old end of the + block, including the trailer.} + DebugFillMem(Pointer(PByte(APointer) + NativeUInt(ANewSize) + SizeOf(NativeUInt))^, + NativeInt(LActualBlock.UserSize) - ANewSize, +{$ifndef CatchUseOfFreedInterfaces} + DebugFillPattern); +{$else} + RotateRight(NativeUInt(@VMTBadInterface), (ANewSize and (SizeOf(Pointer) - 1)) * 8)); +{$endif} + {Update the user size} + LActualBlock.UserSize := ANewSize; + {Set the new checksums} + UpdateHeaderAndFooterCheckSums(LActualBlock); + {$ifdef FullDebugModeCallBacks} + if Assigned(OnDebugReallocMemFinish) then + OnDebugReallocMemFinish(LActualBlock, ANewSize); + {$endif} + finally + {Block scans can again be performed safely} + DoneChangingFullDebugModeBlock; + end; {Return the old pointer} Result := APointer; end; @@ -6428,7 +8918,7 @@ function DebugReallocMem(APointer: Pointer; ANewSize: Integer): Pointer; end; {Allocates a block and fills it with zeroes} -function DebugAllocMem(ASize: Cardinal): Pointer; +function DebugAllocMem(ASize: {$ifdef XE2AndUp}NativeInt{$else}Cardinal{$endif}): Pointer; begin Result := DebugGetMem(ASize); {Clear the block} @@ -6436,13 +8926,21 @@ function DebugAllocMem(ASize: Cardinal): Pointer; FillChar(Result^, ASize, 0); end; -{Raises a runtime error if a memory corruption was encountered.} +{Raises a runtime error if a memory corruption was encountered. Subroutine for + InternalScanMemoryPool and InternalScanSmallBlockPool.} procedure RaiseMemoryCorruptionError; begin {Disable exhaustive checking in order to prevent recursive exceptions.} FullDebugModeScanMemoryPoolBeforeEveryOperation := False; + {Unblock the memory manager in case the creation of the exception below + causes an attempt to be made to allocate memory.} + UnblockFullDebugModeMMRoutines; {Raise the runtime error} +{$ifdef BCB6OrDelphi7AndUp} System.Error(reOutOfMemory); +{$else} + System.RunError(reOutOfMemory); +{$endif} end; {Subroutine for InternalScanMemoryPool: Checks the given small block pool for @@ -6455,10 +8953,10 @@ procedure InternalScanSmallBlockPool(APSmallBlockPool: PSmallBlockPoolHeader; {Get the first and last pointer for the pool} GetFirstAndLastSmallBlockInPool(APSmallBlockPool, LCurPtr, LEndPtr); {Step through all blocks} - while Cardinal(LCurPtr) <= Cardinal(LEndPtr) do + while UIntPtr(LCurPtr) <= UIntPtr(LEndPtr) do begin {Is this block in use? If so, is the debug info intact?} - if ((PCardinal(Cardinal(LCurPtr) - 4)^ and IsFreeBlockFlag) = 0) then + if ((PNativeUInt(PByte(LCurPtr) - BlockHeaderSize)^ and IsFreeBlockFlag) = 0) then begin if CheckBlockBeforeFreeOrRealloc(LCurPtr, boBlockCheck) then begin @@ -6478,7 +8976,7 @@ procedure InternalScanSmallBlockPool(APSmallBlockPool: PSmallBlockPoolHeader; RaiseMemoryCorruptionError; end; {Next block} - Inc(Cardinal(LCurPtr), APSmallBlockPool.BlockType.BlockSize); + Inc(PByte(LCurPtr), APSmallBlockPool.BlockType.BlockSize); end; end; @@ -6490,67 +8988,76 @@ procedure InternalScanMemoryPool(AFirstAllocationGroupToLog, ALastAllocationGrou LPLargeBlock: PLargeBlockHeader; LPMediumBlock: Pointer; LPMediumBlockPoolHeader: PMediumBlockPoolHeader; - LMediumBlockHeader: Cardinal; + LMediumBlockHeader: NativeUInt; begin - {Step through all the medium block pools} - LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; - while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do - begin - LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader); - while LPMediumBlock <> nil do + {Block all the memory manager routines while performing the scan. No memory + block may be allocated or freed, and no FullDebugMode block header or + footer may be modified, while the scan is in progress.} + BlockFullDebugModeMMRoutines; + try + {Step through all the medium block pools} + LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; + while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do begin - LMediumBlockHeader := PCardinal(Cardinal(LPMediumBlock) - 4)^; - {Is the block in use?} - if LMediumBlockHeader and IsFreeBlockFlag = 0 then + LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader); + while LPMediumBlock <> nil do begin - {Block is in use: Is it a medium block or small block pool?} - if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then + LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^; + {Is the block in use?} + if LMediumBlockHeader and IsFreeBlockFlag = 0 then begin - {Get all the leaks for the small block pool} - InternalScanSmallBlockPool(LPMediumBlock, AFirstAllocationGroupToLog, ALastAllocationGroupToLog); - end - else - begin - if CheckBlockBeforeFreeOrRealloc(LPMediumBlock, boBlockCheck) then + {Block is in use: Is it a medium block or small block pool?} + if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then begin - if (PFullDebugBlockHeader(LPMediumBlock).AllocationGroup >= AFirstAllocationGroupToLog) - and (PFullDebugBlockHeader(LPMediumBlock).AllocationGroup <= ALastAllocationGroupToLog) then - begin - LogMemoryLeakOrAllocatedBlock(LPMediumBlock, False); - end; + {Get all the leaks for the small block pool} + InternalScanSmallBlockPool(LPMediumBlock, AFirstAllocationGroupToLog, ALastAllocationGroupToLog); end else + begin + if CheckBlockBeforeFreeOrRealloc(LPMediumBlock, boBlockCheck) then + begin + if (PFullDebugBlockHeader(LPMediumBlock).AllocationGroup >= AFirstAllocationGroupToLog) + and (PFullDebugBlockHeader(LPMediumBlock).AllocationGroup <= ALastAllocationGroupToLog) then + begin + LogMemoryLeakOrAllocatedBlock(LPMediumBlock, False); + end; + end + else + RaiseMemoryCorruptionError; + end; + end + else + begin + {Check that the block has not been modified since being freed} + if not CheckFreeBlockUnmodified(LPMediumBlock, LMediumBlockHeader and DropMediumAndLargeFlagsMask, boBlockCheck) then RaiseMemoryCorruptionError; end; - end - else - begin - {Check that the block has not been modified since being freed} - if not CheckFreeBlockUnmodified(LPMediumBlock, LMediumBlockHeader and DropMediumAndLargeFlagsMask, boBlockCheck) then - RaiseMemoryCorruptionError; + {Next medium block} + LPMediumBlock := NextMediumBlock(LPMediumBlock); end; - {Next medium block} - LPMediumBlock := NextMediumBlock(LPMediumBlock); + {Get the next medium block pool} + LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader; end; - {Get the next medium block pool} - LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader; - end; - {Scan large blocks} - LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; - while (LPLargeBlock <> @LargeBlocksCircularList) do - begin - if CheckBlockBeforeFreeOrRealloc(Pointer(Cardinal(LPLargeBlock) + LargeBlockHeaderSize), boBlockCheck) then + {Scan large blocks} + LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; + while LPLargeBlock <> @LargeBlocksCircularList do begin - if (PFullDebugBlockHeader(Cardinal(LPLargeBlock) + LargeBlockHeaderSize).AllocationGroup >= AFirstAllocationGroupToLog) - and (PFullDebugBlockHeader(Cardinal(LPLargeBlock) + LargeBlockHeaderSize).AllocationGroup <= ALastAllocationGroupToLog) then + if CheckBlockBeforeFreeOrRealloc(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), boBlockCheck) then begin - LogMemoryLeakOrAllocatedBlock(Pointer(Cardinal(LPLargeBlock) + LargeBlockHeaderSize), False); - end; - end - else - RaiseMemoryCorruptionError; - {Get the next large block} - LPLargeBlock := LPLargeBlock.NextLargeBlockHeader; + if (PFullDebugBlockHeader(PByte(LPLargeBlock) + LargeBlockHeaderSize).AllocationGroup >= AFirstAllocationGroupToLog) + and (PFullDebugBlockHeader(PByte(LPLargeBlock) + LargeBlockHeaderSize).AllocationGroup <= ALastAllocationGroupToLog) then + begin + LogMemoryLeakOrAllocatedBlock(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), False); + end; + end + else + RaiseMemoryCorruptionError; + {Get the next large block} + LPLargeBlock := LPLargeBlock.NextLargeBlockHeader; + end; + finally + {Unblock the FullDebugMode memory manager routines.} + UnblockFullDebugModeMMRoutines; end; end; @@ -6651,19 +9158,19 @@ procedure TFreedObject.VirtualMethodError; LActualBlock: PFullDebugBlockHeader; begin {Get the offset of the virtual method} - LVMOffset := (MaxFakeVMTEntries - VMIndex) * 4 + vmtParent + 4; + LVMOffset := (MaxFakeVMTEntries - VMIndex) * SizeOf(Pointer) + vmtParent + SizeOf(Pointer); {Reset the index for the next error} VMIndex := 0; {Get the address of the actual block} - LActualBlock := PFullDebugBlockHeader(Cardinal(Self) - SizeOf(TFullDebugBlockHeader)); + LActualBlock := PFullDebugBlockHeader(PByte(Self) - SizeOf(TFullDebugBlockHeader)); {Display the error header} LMsgPtr := AppendStringToBuffer(VirtualMethodErrorHeader, @LErrorMessage[0], Length(VirtualMethodErrorHeader)); {Is the debug info surrounding the block valid?} if CalculateHeaderCheckSum(LActualBlock) = LActualBlock.HeaderCheckSum then begin {Get the class this block was used for previously} - LClass := GetObjectClass(@LActualBlock.PreviouslyUsedByClass); - if (LClass <> nil) and (Cardinal(LClass) <> Cardinal(@FreedObjectVMT.VMTMethods[0])) then + LClass := DetectClassInstance(@LActualBlock.PreviouslyUsedByClass); + if (LClass <> nil) and (IntPtr(LClass) <> IntPtr(@FreedObjectVMT.VMTMethods[0])) then begin LMsgPtr := AppendStringToBuffer(FreedObjectClassMsg, LMsgPtr, Length(FreedObjectClassMsg)); LMsgPtr := AppendClassNameToBuffer(LClass, LMsgPtr); @@ -6672,38 +9179,42 @@ procedure TFreedObject.VirtualMethodError; LMsgPtr := AppendStringToBuffer(VirtualMethodName, LMsgPtr, Length(VirtualMethodName)); if LVMOffset < 0 then begin - LMsgPtr := AppendStringToBuffer(StandardVirtualMethodNames[LVMOffset div 4], LMsgPtr, Length(StandardVirtualMethodNames[LVMOffset div 4])); + LMsgPtr := AppendStringToBuffer(StandardVirtualMethodNames[LVMOffset div SizeOf(Pointer)], LMsgPtr, Length(StandardVirtualMethodNames[LVMOffset div SizeOf(Pointer)])); end else begin LMsgPtr := AppendStringToBuffer(VirtualMethodOffset, LMsgPtr, Length(VirtualMethodOffset)); - LMsgPtr := CardinalToStrBuf(LVMOffset, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LVMOffset, LMsgPtr); end; {Virtual method address} - if (LClass <> nil) and (Cardinal(LClass) <> Cardinal(@FreedObjectVMT.VMTMethods[0])) then + if (LClass <> nil) and (IntPtr(LClass) <> IntPtr(@FreedObjectVMT.VMTMethods[0])) then begin LMsgPtr := AppendStringToBuffer(VirtualMethodAddress, LMsgPtr, Length(VirtualMethodAddress)); - LMsgPtr := CardinalToHexBuf(PCardinal(Integer(LClass) + LVMOffset)^, LMsgPtr); + LMsgPtr := NativeUIntToHexBuf(PNativeUInt(PByte(LClass) + LVMOffset)^, LMsgPtr); end; {Log the allocation group} if LActualBlock.AllocationGroup > 0 then begin LMsgPtr := AppendStringToBuffer(PreviousAllocationGroupMsg, LMsgPtr, Length(PreviousAllocationGroupMsg)); - LMsgPtr := CardinalToStrBuf(LActualBlock.AllocationGroup, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LActualBlock.AllocationGroup, LMsgPtr); end; {Log the allocation number} LMsgPtr := AppendStringToBuffer(PreviousAllocationNumberMsg, LMsgPtr, Length(PreviousAllocationNumberMsg)); - LMsgPtr := CardinalToStrBuf(LActualBlock.AllocationNumber, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LActualBlock.AllocationNumber, LMsgPtr); {The header is still intact - display info about the this/previous allocation} if LActualBlock.AllocationStackTrace[0] <> 0 then begin - LMsgPtr := AppendStringToBuffer(StackTraceAtObjectAllocMsg, LMsgPtr, Length(StackTraceAtObjectAllocMsg)); + LMsgPtr := AppendStringToBuffer(ThreadIDAtObjectAllocMsg, LMsgPtr, Length(ThreadIDAtObjectAllocMsg)); + LMsgPtr := NativeUIntToHexBuf(LActualBlock.AllocatedByThread, LMsgPtr); + LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg)); LMsgPtr := LogStackTrace(@LActualBlock.AllocationStackTrace, StackTraceDepth, LMsgPtr); end; {Get the call stack for the previous free} if LActualBlock.FreeStackTrace[0] <> 0 then begin - LMsgPtr := AppendStringToBuffer(StackTraceAtObjectFreeMsg, LMsgPtr, Length(StackTraceAtObjectFreeMsg)); + LMsgPtr := AppendStringToBuffer(ThreadIDAtObjectFreeMsg, LMsgPtr, Length(ThreadIDAtObjectFreeMsg)); + LMsgPtr := NativeUIntToHexBuf(LActualBlock.FreedByThread, LMsgPtr); + LMsgPtr := AppendStringToBuffer(StackTraceMsg, LMsgPtr, Length(StackTraceMsg)); LMsgPtr := LogStackTrace(@LActualBlock.FreeStackTrace, StackTraceDepth, LMsgPtr); end; end @@ -6713,9 +9224,11 @@ procedure TFreedObject.VirtualMethodError; LMsgPtr := AppendStringToBuffer(BlockHeaderCorruptedNoHistoryMsg, LMsgPtr, Length(BlockHeaderCorruptedNoHistoryMsg)); end; {Add the current stack trace} - LMsgPtr := LogCurrentStackTrace(2, LMsgPtr); + LMsgPtr := LogCurrentThreadAndStackTrace(2, LMsgPtr); +{$ifndef DisableLoggingOfMemoryDumps} {Add the pointer address} LMsgPtr := LogMemoryDump(LActualBlock, LMsgPtr); +{$endif} {Trailing CRLF} LMsgPtr^ := #13; Inc(LMsgPtr); @@ -6725,7 +9238,7 @@ procedure TFreedObject.VirtualMethodError; LMsgPtr^ := #0; {$ifdef LogErrorsToFile} {Log the error} - AppendEventLog(@LErrorMessage[0], Cardinal(LMsgPtr) - Cardinal(@LErrorMessage[0])); + AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0])); {$endif} {$ifdef UseOutputDebugString} OutputDebugStringA(LErrorMessage); @@ -6751,7 +9264,7 @@ procedure TFreedObject.InterfaceError; {Display the error header} LMsgPtr := AppendStringToBuffer(InterfaceErrorHeader, @LErrorMessage[0], Length(InterfaceErrorHeader)); {Add the current stack trace} - LMsgPtr := LogCurrentStackTrace(2, LMsgPtr); + LMsgPtr := LogCurrentThreadAndStackTrace(2, LMsgPtr); {Trailing CRLF} LMsgPtr^ := #13; Inc(LMsgPtr); @@ -6761,7 +9274,7 @@ procedure TFreedObject.InterfaceError; LMsgPtr^ := #0; {$ifdef LogErrorsToFile} {Log the error} - AppendEventLog(@LErrorMessage[0], Cardinal(LMsgPtr) - Cardinal(@LErrorMessage[0])); + AppendEventLog(@LErrorMessage[0], NativeUInt(LMsgPtr) - NativeUInt(@LErrorMessage[0])); {$endif} {$ifdef UseOutputDebugString} OutputDebugStringA(LErrorMessage); @@ -6792,10 +9305,10 @@ function UpdateExpectedLeakList(APLeakList: PPExpectedMemoryLeak; Result := False; {Find the insertion spot} LPInsertAfter := APLeakList^; - while (LPInsertAfter <> nil) do + while LPInsertAfter <> nil do begin {Too big?} - if (LPInsertAfter.LeakSize > APNewEntry.LeakSize) then + if LPInsertAfter.LeakSize > APNewEntry.LeakSize then begin LPInsertAfter := LPInsertAfter.PreviousLeak; Break; @@ -6803,8 +9316,8 @@ function UpdateExpectedLeakList(APLeakList: PPExpectedMemoryLeak; {Find a matching entry. If an exact size match is not required and the leak is larger than the current entry, use it if the expected size of the next entry is too large.} - if (Cardinal(LPInsertAfter.LeakAddress) = Cardinal(APNewEntry.LeakAddress)) - and ((Cardinal(LPInsertAfter.LeakedClass) = Cardinal(APNewEntry.LeakedClass)) + if (IntPtr(LPInsertAfter.LeakAddress) = IntPtr(APNewEntry.LeakAddress)) + and ((IntPtr(LPInsertAfter.LeakedClass) = IntPtr(APNewEntry.LeakedClass)) {$ifdef CheckCppObjectTypeEnabled} or (LPInsertAfter.LeakedCppTypeIdPtr = APNewEntry.LeakedCppTypeIdPtr) {$endif} @@ -6816,7 +9329,7 @@ function UpdateExpectedLeakList(APLeakList: PPExpectedMemoryLeak; or (LPInsertAfter.NextLeak.LeakSize > APNewEntry.LeakSize)) )) then begin - if Integer(LPInsertAfter.LeakCount + APNewEntry.LeakCount) >= 0 then + if (LPInsertAfter.LeakCount + APNewEntry.LeakCount) >= 0 then begin Inc(LPInsertAfter.LeakCount, APNewEntry.LeakCount); {Is the count now 0?} @@ -6853,7 +9366,7 @@ function UpdateExpectedLeakList(APLeakList: PPExpectedMemoryLeak; end else begin - if (ExpectedMemoryLeaks.EntriesUsed < length(ExpectedMemoryLeaks.ExpectedLeaks)) then + if ExpectedMemoryLeaks.EntriesUsed < Length(ExpectedMemoryLeaks.ExpectedLeaks) then begin LPNewEntry := @ExpectedMemoryLeaks.ExpectedLeaks[ExpectedMemoryLeaks.EntriesUsed]; Inc(ExpectedMemoryLeaks.EntriesUsed); @@ -6896,7 +9409,11 @@ function LockExpectedMemoryLeaksList: Boolean; begin while LockCmpxchg(0, 1, @ExpectedMemoryLeaksListLocked) <> 0 do begin -{$ifndef NeverSleepOnThreadContention} +{$ifdef NeverSleepOnThreadContention} + {$ifdef UseSwitchToThread} + SwitchToThread; + {$endif} +{$else} Sleep(InitialSleepTime); if LockCmpxchg(0, 1, @ExpectedMemoryLeaksListLocked) = 0 then Break; @@ -6921,7 +9438,7 @@ function RegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overload; {$ifndef FullDebugMode} LNewEntry.LeakAddress := ALeakedPointer; {$else} - LNewEntry.LeakAddress := Pointer(Cardinal(ALeakedPointer) - SizeOf(TFullDebugBlockHeader)); + LNewEntry.LeakAddress := Pointer(PByte(ALeakedPointer) - SizeOf(TFullDebugBlockHeader)); {$endif} LNewEntry.LeakedClass := nil; {$ifdef CheckCppObjectTypeEnabled} @@ -6954,7 +9471,7 @@ function RegisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Integer end; {$ifdef CheckCppObjectTypeEnabled} -function RegisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer = 1): Boolean; overload; +function RegisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): Boolean; overload; var LNewEntry: TExpectedMemoryLeak; begin @@ -6986,7 +9503,7 @@ function RegisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: end; {$endif} -function RegisterExpectedMemoryLeak(ALeakedBlockSize: Integer; ACount: Integer = 1): Boolean; overload; +function RegisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload; var LNewEntry: TExpectedMemoryLeak; begin @@ -7012,7 +9529,7 @@ function UnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; overloa {$ifndef FullDebugMode} LNewEntry.LeakAddress := ALeakedPointer; {$else} - LNewEntry.LeakAddress := Pointer(Cardinal(ALeakedPointer) - SizeOf(TFullDebugBlockHeader)); + LNewEntry.LeakAddress := Pointer(PByte(ALeakedPointer) - SizeOf(TFullDebugBlockHeader)); {$endif} LNewEntry.LeakedClass := nil; {$ifdef CheckCppObjectTypeEnabled} @@ -7032,13 +9549,13 @@ function UnregisterExpectedMemoryLeak(ALeakedObjectClass: TClass; ACount: Intege end; {$ifdef CheckCppObjectTypeEnabled} -function UnregisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer = 1): Boolean; overload; +function UnregisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr: Pointer; ACount: Integer): Boolean; overload; begin Result := RegisterExpectedMemoryLeak(ALeakedCppVirtObjTypeIdPtr, - ACount); end; {$endif} -function UnregisterExpectedMemoryLeak(ALeakedBlockSize: Integer; ACount: Integer = 1): Boolean; overload; +function UnregisterExpectedMemoryLeak(ALeakedBlockSize: NativeInt; ACount: Integer = 1): Boolean; overload; begin Result := RegisterExpectedMemoryLeak(ALeakedBlockSize, - ACount); end; @@ -7048,17 +9565,17 @@ function GetRegisteredMemoryLeaks: TRegisteredMemoryLeaks; procedure AddEntries(AEntry: PExpectedMemoryLeak); var - LInd: integer; + LInd: Integer; begin while AEntry <> nil do begin - LInd := length(Result); + LInd := Length(Result); SetLength(Result, LInd + 1); {Add the entry} {$ifndef FullDebugMode} Result[LInd].LeakAddress := AEntry.LeakAddress; {$else} - Result[LInd].LeakAddress := Pointer(Cardinal(AEntry.LeakAddress) + SizeOf(TFullDebugBlockHeader)); + Result[LInd].LeakAddress := Pointer(PByte(AEntry.LeakAddress) + SizeOf(TFullDebugBlockHeader)); {$endif} Result[LInd].LeakedClass := AEntry.LeakedClass; {$ifdef CheckCppObjectTypeEnabled} @@ -7089,22 +9606,112 @@ function GetRegisteredMemoryLeaks: TRegisteredMemoryLeaks; function NoOpRegisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; begin {Do nothing. Used when memory leak reporting is disabled under Delphi 2006 and later.} + Result := False; end; function NoOpUnregisterExpectedMemoryLeak(ALeakedPointer: Pointer): Boolean; begin {Do nothing. Used when memory leak reporting is disabled under Delphi 2006 and later.} + Result := False; end; {$endif} {$endif} -{Checks blocks for modification after free and also for memory - leaks} +{Detects the probable string data type for a memory block.} +function DetectStringData(APMemoryBlock: Pointer; + AAvailableSpaceInBlock: NativeInt): TStringDataType; +const + {If the string reference count field contains a value greater than this, + then it is assumed that the block is not a string.} + MaxRefCount = 255; + {The lowest ASCII character code considered valid string data. If there are + any characters below this code point then the data is assumed not to be a + string. #9 = Tab.} + MinCharCode = #9; +var + LStringLength, LElemSize, LCharInd: Integer; + LPAnsiStr: PAnsiChar; + LPUniStr: PWideChar; +begin + {Check that the reference count is within a reasonable range} + if PStrRec(APMemoryBlock).refCnt > MaxRefCount then + begin + Result := stUnknown; + Exit; + end; +{$ifdef BCB6OrDelphi6AndUp} + {$if RTLVersion >= 20} + LElemSize := PStrRec(APMemoryBlock).elemSize; + {Element size must be either 1 (Ansi) or 2 (Unicode)} + if (LElemSize <> 1) and (LElemSize <> 2) then + begin + Result := stUnknown; + Exit; + end; + {$ifend} + {$if RTLVersion < 20} + LElemSize := 1; + {$ifend} +{$else} + LElemSize := 1; +{$endif} + {Get the string length} + LStringLength := PStrRec(APMemoryBlock).length; + {Does the string fit?} + if (LStringLength <= 0) + or (LStringLength >= (AAvailableSpaceInBlock - SizeOf(StrRec)) div LElemSize) then + begin + Result := stUnknown; + Exit; + end; + {Check for no characters outside the expected range. If there are, + then it is probably not a string.} + if LElemSize = 1 then + begin + {Check that all characters are in the range considered valid.} + LPAnsiStr := PAnsiChar(PByte(APMemoryBlock) + SizeOf(StrRec)); + for LCharInd := 1 to LStringLength do + begin + if LPAnsiStr^ < MinCharCode then + begin + Result := stUnknown; + Exit; + end; + Inc(LPAnsiStr); + end; + {Must have a trailing #0} + if LPAnsiStr^ = #0 then + Result := stAnsiString + else + Result := stUnknown; + end + else + begin + {Check that all characters are in the range considered valid.} + LPUniStr := PWideChar(PByte(APMemoryBlock) + SizeOf(StrRec)); + for LCharInd := 1 to LStringLength do + begin + if LPUniStr^ < MinCharCode then + begin + Result := stUnknown; + Exit; + end; + Inc(LPUniStr); + end; + {Must have a trailing #0} + if LPUniStr^ = #0 then + Result := stUnicodeString + else + Result := stUnknown; + end; +end; + +{Checks blocks for modification after free and also for memory leaks} procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); {$ifdef EnableMemoryLeakReporting} type {Leaked class type} - TLeakedClass = packed record + TLeakedClass = record ClassPointer: TClass; {$ifdef CheckCppObjectTypeEnabled} CppTypeIdPtr: Pointer; @@ -7116,7 +9723,7 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); {Leak statistics for a small block type} TSmallBlockLeaks = array[0..NumSmallBlockTypes - 1] of TLeakedClasses; {A leaked medium or large block} - TMediumAndLargeBlockLeaks = array[0..4095] of Cardinal; + TMediumAndLargeBlockLeaks = array[0..4095] of NativeUInt; {$endif} var {$ifdef EnableMemoryLeakReporting} @@ -7136,17 +9743,17 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); {$endif} LMsgPtr: PAnsiChar; LExpectedLeaksOnly, LSmallLeakHeaderAdded, LBlockSizeHeaderAdded: Boolean; - LBlockTypeInd, LMediumBlockSize, LLargeBlockSize, - LClassInd, LPreviousBlockSize, LThisBlockSize, LBlockInd: Cardinal; + LBlockTypeInd, LClassInd, LBlockInd: Cardinal; + LMediumBlockSize, LPreviousBlockSize, LLargeBlockSize, LThisBlockSize: NativeUInt; {$endif} LPMediumBlock: Pointer; LPMediumBlockPoolHeader: PMediumBlockPoolHeader; - LMediumBlockHeader: Cardinal; + LMediumBlockHeader: NativeUInt; {$ifdef EnableMemoryLeakReporting} {Tries to account for a memory leak. Returns true if the leak is expected and removes the leak from the list} - function GetMemoryLeakType(AAddress: Pointer; ASpaceInsideBlock: Cardinal): TMemoryLeakType; + function GetMemoryLeakType(AAddress: Pointer; ASpaceInsideBlock: NativeUInt): TMemoryLeakType; var LLeak: TExpectedMemoryLeak; begin @@ -7170,15 +9777,15 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); {Check by class} LLeak.LeakAddress := nil; {$ifdef FullDebugMode} - LLeak.LeakedClass := TClass(PCardinal(Cardinal(AAddress)+ SizeOf(TFullDebugBlockHeader))^); + LLeak.LeakedClass := TClass(PNativeUInt(PByte(AAddress)+ SizeOf(TFullDebugBlockHeader))^); {$else} - LLeak.LeakedClass := TClass(PCardinal(AAddress)^); + LLeak.LeakedClass := TClass(PNativeUInt(AAddress)^); {$endif} {$ifdef CheckCppObjectTypeEnabled} if Assigned(GetCppVirtObjTypeIdPtrFunc) then begin {$ifdef FullDebugMode} - LLeak.LeakedCppTypeIdPtr := GetCppVirtObjTypeIdPtrFunc(Pointer(Cardinal(AAddress) + LLeak.LeakedCppTypeIdPtr := GetCppVirtObjTypeIdPtrFunc(Pointer(PByte(AAddress) + SizeOf(TFullDebugBlockHeader)), ASpaceInsideBlock); {$else} LLeak.LeakedCppTypeIdPtr := GetCppVirtObjTypeIdPtrFunc(AAddress, ASpaceInsideBlock); @@ -7207,10 +9814,7 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); LLeakedCppObjectTypeId: Pointer; {$endif} LSmallBlockLeakType: TMemoryLeakType; - LCharInd, LClassIndex, LStringLength, LElemSize, LStringMemReq: Integer; - LPAnsiStr: PAnsiChar; - LPUniStr: PWideChar; - LPossibleString: Boolean; + LClassIndex: Integer; LCurPtr, LEndPtr, LDataPtr: Pointer; LBlockTypeIndex: Cardinal; LPLeakedClasses: PLeakedClasses; @@ -7222,15 +9826,15 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); Dec(LSmallBlockSize, FullDebugBlockOverhead); {$endif} {Get the block type index} - LBlockTypeIndex := (Cardinal(APSmallBlockPool.BlockType) - Cardinal(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType); + LBlockTypeIndex := (UIntPtr(APSmallBlockPool.BlockType) - UIntPtr(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType); LPLeakedClasses := @LSmallBlockLeaks[LBlockTypeIndex]; {Get the first and last pointer for the pool} GetFirstAndLastSmallBlockInPool(APSmallBlockPool, LCurPtr, LEndPtr); {Step through all blocks} - while Cardinal(LCurPtr) <= Cardinal(LEndPtr) do + while UIntPtr(LCurPtr) <= UIntPtr(LEndPtr) do begin {Is this block in use? If so, is the debug info intact?} - if ((PCardinal(Cardinal(LCurPtr) - 4)^ and IsFreeBlockFlag) = 0) then + if ((PNativeUInt(PByte(LCurPtr) - BlockHeaderSize)^ and IsFreeBlockFlag) = 0) then begin {$ifdef FullDebugMode} if CheckBlockBeforeFreeOrRealloc(LCurPtr, boBlockCheck) then @@ -7257,12 +9861,12 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); {$ifndef FullDebugMode} LDataPtr := LCurPtr; {$else} - LDataPtr := Pointer(Cardinal(LCurPtr) + SizeOf(TFullDebugBlockHeader)); + LDataPtr := Pointer(PByte(LCurPtr) + SizeOf(TFullDebugBlockHeader)); {$endif} {Default to an unknown block} LClassIndex := 0; {Get the class contained by the block} - LLeakedClass := GetObjectClass(LDataPtr); + LLeakedClass := DetectClassInstance(LDataPtr); {Not a Delphi class? -> is it perhaps a string or C++ object type?} if LLeakedClass = nil then begin @@ -7296,58 +9900,10 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); else begin {$endif} - {Reference count < 256} - if PStrRec(LDataPtr).refCnt < 256 then - begin - {Get the string length and element size} - LStringLength := PStrRec(LDataPtr).length; - {In anticipation of Tiburon: Will be 2 for UnicodeString} - LElemSize := 1; - {Valid element size?} - if (LElemSize = 1) or (LElemSize = 2) then - begin - {Calculate the amount of memory required for the string} - LStringMemReq := (LStringLength + 1) * LElemSize + SizeOf(StrRec); - {Does the string fit?} - if (LStringLength > 0) - and (LStringMemReq <= (APSmallBlockPool.BlockType.BlockSize - (BlockHeaderSize {$ifdef FullDebugMode} + FullDebugBlockOverhead{$endif}))) then - begin - {It is possibly a string} - LPossibleString := True; - {Check for no characters < #32. If there are, then it is - probably not a string.} - if LElemSize = 1 then - begin - {Check that all characters are >= #32} - LPAnsiStr := PAnsiChar(Cardinal(LDataPtr) + SizeOf(StrRec)); - for LCharInd := 1 to LStringLength do - begin - LPossibleString := LPossibleString and (LPAnsiStr^ >= #32); - Inc(LPAnsiStr); - end; - {Must have a trailing #0} - if LPossibleString and (LPAnsiStr^ = #0) then - begin - LClassIndex := 1; - end; - end - else - begin - {Check that all characters are >= #32} - LPUniStr := PWideChar(Cardinal(LDataPtr) + SizeOf(StrRec)); - for LCharInd := 1 to LStringLength do - begin - LPossibleString := LPossibleString and (LPUniStr^ >= #32); - Inc(LPUniStr); - end; - {Must have a trailing #0} - if LPossibleString and (LPUniStr^ = #0) then - begin - LClassIndex := 2; - end; - end; - end; - end; + {Not a known class: Is it perhaps string data?} + case DetectStringData(LDataPtr, APSmallBlockPool.BlockType.BlockSize - (BlockHeaderSize {$ifdef FullDebugMode} + FullDebugBlockOverhead{$endif})) of + stAnsiString: LClassIndex := 1; + stUnicodeString: LClassIndex := 2; end; {$ifdef CheckCppObjectTypeEnabled} end; @@ -7387,7 +9943,7 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); {$endif} end; {Next block} - Inc(Cardinal(LCurPtr), APSmallBlockPool.BlockType.BlockSize); + Inc(PByte(LCurPtr), APSmallBlockPool.BlockType.BlockSize); end; end; {$endif} @@ -7409,7 +9965,7 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader); while LPMediumBlock <> nil do begin - LMediumBlockHeader := PCardinal(Cardinal(LPMediumBlock) - 4)^; + LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^; {Is the block in use?} if LMediumBlockHeader and IsFreeBlockFlag = 0 then begin @@ -7423,7 +9979,7 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); end else begin - if (LNumMediumAndLargeLeaks < length(LMediumAndLargeBlockLeaks)) + if (LNumMediumAndLargeLeaks < Length(LMediumAndLargeBlockLeaks)) {$ifdef FullDebugMode} and CheckBlockBeforeFreeOrRealloc(LPMediumBlock, boBlockCheck) {$endif} @@ -7474,11 +10030,11 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); begin {Get all leaked large blocks} LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; - while (LPLargeBlock <> @LargeBlocksCircularList) do + while LPLargeBlock <> @LargeBlocksCircularList do begin if (LNumMediumAndLargeLeaks < length(LMediumAndLargeBlockLeaks)) {$ifdef FullDebugMode} - and CheckBlockBeforeFreeOrRealloc(Pointer(Cardinal(LPLargeBlock) + LargeBlockHeaderSize), boBlockCheck) + and CheckBlockBeforeFreeOrRealloc(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), boBlockCheck) {$endif} then begin @@ -7487,14 +10043,14 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); Dec(LLargeBlockSize, FullDebugBlockOverhead); {$endif} {Get the leak type} - LLeakType := GetMemoryLeakType(Pointer(Cardinal(LPLargeBlock) + LargeBlockHeaderSize), LLargeBlockSize); + LLeakType := GetMemoryLeakType(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), LLargeBlockSize); {Is it an expected leak?} LExpectedLeaksOnly := LExpectedLeaksOnly and (LLeakType <> mltUnexpectedLeak); {$ifdef LogMemoryLeakDetailToFile} {$ifdef HideExpectedLeaksRegisteredByPointer} if LLeakType <> mltExpectedLeakRegisteredByPointer then {$endif} - LogMemoryLeakOrAllocatedBlock(Pointer(Cardinal(LPLargeBlock) + LargeBlockHeaderSize), True); + LogMemoryLeakOrAllocatedBlock(Pointer(PByte(LPLargeBlock) + LargeBlockHeaderSize), True); {$endif} {$ifdef HideExpectedLeaksRegisteredByPointer} if LLeakType <> mltExpectedLeakRegisteredByPointer then @@ -7522,7 +10078,7 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); LThisBlockSize := SmallBlockTypes[LBlockTypeInd].BlockSize - BlockHeaderSize; {$ifdef FullDebugMode} Dec(LThisBlockSize, FullDebugBlockOverhead); - if Integer(LThisBlockSize) < 0 then + if NativeInt(LThisBlockSize) < 0 then LThisBlockSize := 0; {$endif} LBlockSizeHeaderAdded := False; @@ -7531,7 +10087,7 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); begin {Is there still space in the message buffer? Reserve space for the message footer.} - if LMsgPtr > @LLeakMessage[high(LLeakMessage) - 2048] then + if LMsgPtr > @LLeakMessage[High(LLeakMessage) - 2048] then Break; {Check the count} if LSmallBlockLeaks[LBlockTypeInd][LClassInd].NumLeaks > 0 then @@ -7549,14 +10105,14 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); Inc(LMsgPtr); LMsgPtr^ := #10; Inc(LMsgPtr); - LMsgPtr := CardinalToStrBuf(LPreviousBlockSize + 1, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LPreviousBlockSize + 1, LMsgPtr); LMsgPtr^ := ' '; Inc(LMsgPtr); LMsgPtr^ := '-'; Inc(LMsgPtr); LMsgPtr^ := ' '; Inc(LMsgPtr); - LMsgPtr := CardinalToStrBuf(LThisBlockSize, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LThisBlockSize, LMsgPtr); LMsgPtr := AppendStringToBuffer(BytesMessage, LMsgPtr, Length(BytesMessage)); LBlockSizeHeaderAdded := True; end @@ -7614,7 +10170,7 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); Inc(LMsgPtr); LMsgPtr^ := ' '; Inc(LMsgPtr); - LMsgPtr := CardinalToStrBuf(LSmallBlockLeaks[LBlockTypeInd][LClassInd].NumLeaks, LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LSmallBlockLeaks[LBlockTypeInd][LClassInd].NumLeaks, LMsgPtr); end; end; LPreviousBlockSize := LThisBlockSize; @@ -7646,10 +10202,10 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); LMsgPtr^ := ' '; Inc(LMsgPtr); end; - LMsgPtr := CardinalToStrBuf(LMediumAndLargeBlockLeaks[LBlockInd], LMsgPtr); + LMsgPtr := NativeUIntToStrBuf(LMediumAndLargeBlockLeaks[LBlockInd], LMsgPtr); {Is there still space in the message buffer? Reserve space for the message footer.} - if LMsgPtr > @LLeakMessage[high(LLeakMessage) - 2048] then + if LMsgPtr > @LLeakMessage[High(LLeakMessage) - 2048] then Break; end; end; @@ -7657,7 +10213,7 @@ procedure CheckBlocksOnShutdown(ACheckForLeakedBlocks: Boolean); {Set the message footer} LMsgPtr := AppendStringToBuffer(LeakMessageFooter, LMsgPtr, Length(LeakMessageFooter)); {Append the message to the memory errors file} - AppendEventLog(@LLeakMessage[0], Cardinal(LMsgPtr) - Cardinal(@LLeakMessage[1])); + AppendEventLog(@LLeakMessage[0], UIntPtr(LMsgPtr) - UIntPtr(@LLeakMessage[1])); {$else} {Set the message footer} AppendStringToBuffer(LeakMessageFooter, LMsgPtr, Length(LeakMessageFooter)); @@ -7681,7 +10237,8 @@ procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState); LPMediumBlockPoolHeader: PMediumBlockPoolHeader; LPMediumBlock: Pointer; LInd: Integer; - LBlockTypeIndex, LMediumBlockSize, LMediumBlockHeader, LLargeBlockSize: Cardinal; + LBlockTypeIndex, LMediumBlockSize: Cardinal; + LMediumBlockHeader, LLargeBlockSize: NativeUInt; LPLargeBlock: PLargeBlockHeader; begin {Clear the structure} @@ -7693,7 +10250,7 @@ procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState); SmallBlockTypes[LInd].BlockSize; AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize := SmallBlockTypes[LInd].BlockSize - BlockHeaderSize{$ifdef FullDebugMode} - FullDebugBlockOverhead{$endif}; - if Integer(AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize) < 0 then + if NativeInt(AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize) < 0 then AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize := 0; end; {Lock all small block types} @@ -7709,7 +10266,7 @@ procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState); LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader); while LPMediumBlock <> nil do begin - LMediumBlockHeader := PCardinal(Cardinal(LPMediumBlock) - 4)^; + LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^; {Is the block in use?} if LMediumBlockHeader and IsFreeBlockFlag = 0 then begin @@ -7718,7 +10275,7 @@ procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState); if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then begin {Get the block type index} - LBlockTypeIndex := (Cardinal(PSmallBlockPoolHeader(LPMediumBlock).BlockType) - Cardinal(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType); + LBlockTypeIndex := (UIntPtr(PSmallBlockPoolHeader(LPMediumBlock).BlockType) - UIntPtr(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType); {Subtract from medium block usage} Dec(AMemoryManagerState.ReservedMediumBlockAddressSpace, LMediumBlockSize); {Add it to the reserved space for the block size} @@ -7750,7 +10307,7 @@ procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState); {Step through all the large blocks} LockLargeBlocks; LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; - while (LPLargeBlock <> @LargeBlocksCircularList) do + while LPLargeBlock <> @LargeBlocksCircularList do begin LLargeBlockSize := LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask; Inc(AMemoryManagerState.AllocatedLargeBlockCount); @@ -7767,7 +10324,7 @@ procedure GetMemoryManagerUsageSummary( var AMemoryManagerUsageSummary: TMemoryManagerUsageSummary); var LMMS: TMemoryManagerState; - LAllocatedBytes, LReservedBytes: Cardinal; + LAllocatedBytes, LReservedBytes: NativeUInt; LSBTIndex: Integer; begin {Get the memory manager state} @@ -7796,25 +10353,30 @@ procedure GetMemoryManagerUsageSummary( end; {$ifndef Linux} -{Gets the state of every 64K block in the 4GB address space} +{Gets the state of every 64K block in the 4GB address space. Under 64-bit this + returns only the state for the low 4GB.} procedure GetMemoryMap(var AMemoryMap: TMemoryMap); var LPMediumBlockPoolHeader: PMediumBlockPoolHeader; LPLargeBlock: PLargeBlockHeader; - LLargeBlockSize, LChunkIndex, LInd, LNextChunk: Cardinal; + LInd, LChunkIndex, LNextChunk, LLargeBlockSize: NativeUInt; LMBI: TMemoryBasicInformation; begin {Clear the map} - FillChar(AMemoryMap, SizeOf(AMemoryMap), ord(csUnallocated)); + FillChar(AMemoryMap, SizeOf(AMemoryMap), Ord(csUnallocated)); {Step through all the medium block pools} LockMediumBlocks; LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do begin {Add to the medium block used space} - LChunkIndex := Cardinal(LPMediumBlockPoolHeader) shr 16; + LChunkIndex := NativeUInt(LPMediumBlockPoolHeader) shr 16; for LInd := 0 to (MediumBlockPoolSize - 1) shr 16 do + begin + if (LChunkIndex + LInd) > High(AMemoryMap) then + Break; AMemoryMap[LChunkIndex + LInd] := csAllocated; + end; {Get the next medium block pool} LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader; end; @@ -7822,12 +10384,16 @@ procedure GetMemoryMap(var AMemoryMap: TMemoryMap); {Step through all the large blocks} LockLargeBlocks; LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; - while (LPLargeBlock <> @LargeBlocksCircularList) do + while LPLargeBlock <> @LargeBlocksCircularList do begin - LChunkIndex := Cardinal(LPLargeBlock) shr 16; + LChunkIndex := UIntPtr(LPLargeBlock) shr 16; LLargeBlockSize := LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask; for LInd := 0 to (LLargeBlockSize - 1) shr 16 do + begin + if (LChunkIndex + LInd) > High(AMemoryMap) then + Break; AMemoryMap[LChunkIndex + LInd] := csAllocated; + end; {Get the next large block} LPLargeBlock := LPLargeBlock.NextLargeBlockHeader; end; @@ -7840,7 +10406,13 @@ procedure GetMemoryMap(var AMemoryMap: TMemoryMap); if AMemoryMap[LInd] = csUnallocated then begin {Query the address space starting at the chunk boundary} - VirtualQuery(Pointer(LInd * 65536), LMBI, SizeOf(LMBI)); + if VirtualQuery(Pointer(LInd * 65536), LMBI, SizeOf(LMBI)) = 0 then + begin + {VirtualQuery may fail for addresses >2GB if a large address space is + not enabled.} + FillChar(AMemoryMap[LInd], 65536 - LInd, csSysReserved); + Break; + end; {Get the chunk number after the region} LNextChunk := (LMBI.RegionSize - 1) shr 16 + LInd + 1; {Validate} @@ -7874,8 +10446,8 @@ function FastGetHeapStatus: THeapStatus; var LPMediumBlockPoolHeader: PMediumBlockPoolHeader; LPMediumBlock: Pointer; - LBlockTypeIndex, LMediumBlockSize, LMediumBlockHeader, LLargeBlockSize, - LSmallBlockUsage, LSmallBlockOverhead: Cardinal; + LBlockTypeIndex, LMediumBlockSize: Cardinal; + LSmallBlockUsage, LSmallBlockOverhead, LMediumBlockHeader, LLargeBlockSize: NativeUInt; LInd: Integer; LPLargeBlock: PLargeBlockHeader; begin @@ -7900,7 +10472,7 @@ function FastGetHeapStatus: THeapStatus; while LPMediumBlock <> nil do begin {Get the block header} - LMediumBlockHeader := PCardinal(Cardinal(LPMediumBlock) - 4)^; + LMediumBlockHeader := PNativeUInt(PByte(LPMediumBlock) - BlockHeaderSize)^; {Get the block size} LMediumBlockSize := LMediumBlockHeader and DropMediumAndLargeFlagsMask; {Is the block in use?} @@ -7909,7 +10481,7 @@ function FastGetHeapStatus: THeapStatus; if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then begin {Get the block type index} - LBlockTypeIndex := (Cardinal(PSmallBlockPoolHeader(LPMediumBlock).BlockType) - Cardinal(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType); + LBlockTypeIndex := (UIntPtr(PSmallBlockPoolHeader(LPMediumBlock).BlockType) - UIntPtr(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType); {Get the usage in the block} LSmallBlockUsage := PSmallBlockPoolHeader(LPMediumBlock).BlocksInUse * SmallBlockTypes[LBlockTypeIndex].BlockSize; @@ -7953,7 +10525,7 @@ function FastGetHeapStatus: THeapStatus; {Step through all the large blocks} LockLargeBlocks; LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; - while (LPLargeBlock <> @LargeBlocksCircularList) do + while LPLargeBlock <> @LargeBlocksCircularList do begin LLargeBlockSize := LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask; Inc(Result.TotalAddrSpace, LLargeBlockSize); @@ -7970,13 +10542,13 @@ function FastGetHeapStatus: THeapStatus; Result.TotalFree := Result.FreeSmall + Result.FreeBig + Result.Unused; end; -{Frees all allocated memory.} +{Frees all allocated memory. Does not support segmented large blocks (yet).} procedure FreeAllMemory; var LPMediumBlockPoolHeader, LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader; LPMediumFreeBlock: PMediumFreeBlock; LPLargeBlock, LPNextLargeBlock: PLargeBlockHeader; - LInd: integer; + LInd: Integer; begin {Free all block pools} LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; @@ -7984,35 +10556,49 @@ procedure FreeAllMemory; begin {Get the next medium block pool so long} LPNextMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader; +{$ifdef ClearMediumBlockPoolsBeforeReturningToOS} + FillChar(LPMediumBlockPoolHeader^, MediumBlockPoolSize, 0); +{$else} + {$ifdef ClearSmallAndMediumBlocksInFreeMem} + FillChar(LPMediumBlockPoolHeader^, MediumBlockPoolSize, 0); + {$endif} +{$endif} {Free this pool} VirtualFree(LPMediumBlockPoolHeader, 0, MEM_RELEASE); {Next pool} LPMediumBlockPoolHeader := LPNextMediumBlockPoolHeader; end; {Clear all small block types} - for LInd := 0 to high(SmallBlockTypes) do + for LInd := 0 to High(SmallBlockTypes) do begin SmallBlockTypes[Lind].PreviousPartiallyFreePool := @SmallBlockTypes[Lind]; SmallBlockTypes[Lind].NextPartiallyFreePool := @SmallBlockTypes[Lind]; - SmallBlockTypes[Lind].NextSequentialFeedBlockAddress := pointer(1); + SmallBlockTypes[Lind].NextSequentialFeedBlockAddress := Pointer(1); SmallBlockTypes[Lind].MaxSequentialFeedBlockAddress := nil; end; {Clear all medium block pools} MediumBlockPoolsCircularList.PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList; MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := @MediumBlockPoolsCircularList; {All medium bins are empty} - for LInd := 0 to high(MediumBlockBins) do + for LInd := 0 to High(MediumBlockBins) do begin LPMediumFreeBlock := @MediumBlockBins[LInd]; LPMediumFreeBlock.PreviousFreeBlock := LPMediumFreeBlock; LPMediumFreeBlock.NextFreeBlock := LPMediumFreeBlock; end; + MediumBlockBinGroupBitmap := 0; + FillChar(MediumBlockBinBitmaps, SizeOf(MediumBlockBinBitmaps), 0); + MediumSequentialFeedBytesLeft := 0; {Free all large blocks} LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; while LPLargeBlock <> @LargeBlocksCircularList do begin {Get the next large block} LPNextLargeBlock := LPLargeBlock.NextLargeBlockHeader; +{$ifdef ClearLargeBlocksBeforeReturningToOS} + FillChar(LPLargeBlock^, + LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask, 0); +{$endif} {Free this large block} VirtualFree(LPLargeBlock, 0, MEM_RELEASE); {Next large block} @@ -8035,6 +10621,16 @@ function CheckCanInstallMemoryManager: Boolean; begin {Default to error} Result := False; +{$ifdef FullDebugMode} + {$ifdef LoadDebugDLLDynamically} + {$ifdef DoNotInstallIfDLLMissing} + {Should FastMM be installed only if the FastMM_FullDebugMode.dll file is + available?} + if FullDebugModeDLL = 0 then + Exit; + {$endif} + {$endif} +{$endif} {Is FastMM already installed?} if FastMMIsInstalled then begin @@ -8047,8 +10643,8 @@ function CheckCanInstallMemoryManager: Boolean; {$endif} Exit; end; - {Has another MM been set, or has the Borland MM been used? If so, this file - is not the first unit in the uses clause of the project's .dpr file.} + {Has another MM been set, or has the Embarcadero MM been used? If so, this + file is not the first unit in the uses clause of the project's .dpr file.} if IsMemoryManagerSet then begin {When using runtime packages, another library may already have installed @@ -8066,7 +10662,7 @@ function CheckCanInstallMemoryManager: Boolean; Exit; end; {$ifndef Linux} - if (GetHeapStatus.TotalAllocated <> 0) then + if GetHeapStatus.TotalAllocated <> 0 then begin {Memory has been already been allocated with the RTL MM} {$ifdef UseOutputDebugString} @@ -8085,6 +10681,9 @@ function CheckCanInstallMemoryManager: Boolean; {Initializes the lookup tables for the memory manager} procedure InitializeMemoryManager; +const + {The size of the Inc(VMTIndex) code in TFreedObject.GetVirtualMethodIndex} + VMTIndexIncCodeSize = 6; var LInd, LSizeInd, LMinimumPoolSize, LOptimalPoolSize, LGroupNumber, LBlocksPerPool, LPreviousBlockSize: Cardinal; @@ -8110,7 +10709,7 @@ procedure InitializeMemoryManager; {Initialize the memory manager} {-------------Set up the small block types-------------} LPreviousBlockSize := 0; - for LInd := 0 to high(SmallBlockTypes) do + for LInd := 0 to High(SmallBlockTypes) do begin {Set the move procedure} {$ifdef UseCustomFixedSizeMoveRoutines} @@ -8119,7 +10718,7 @@ procedure InitializeMemoryManager; the old size.} if not Assigned(SmallBlockTypes[LInd].UpsizeMoveProcedure) then {$ifdef UseCustomVariableSizeMoveRoutines} - SmallBlockTypes[LInd].UpsizeMoveProcedure := MoveX16L4; + SmallBlockTypes[LInd].UpsizeMoveProcedure := MoveX16LP; {$else} SmallBlockTypes[LInd].UpsizeMoveProcedure := @System.Move; {$endif} @@ -8134,8 +10733,8 @@ procedure InitializeMemoryManager; AllocSize2SmallBlockTypeIndX4[LSizeInd] := LInd * 4; {Cannot sequential feed yet: Ensure that the next address is greater than the maximum address} - SmallBlockTypes[LInd].MaxSequentialFeedBlockAddress := pointer(0); - SmallBlockTypes[LInd].NextSequentialFeedBlockAddress := pointer(1); + SmallBlockTypes[LInd].MaxSequentialFeedBlockAddress := Pointer(0); + SmallBlockTypes[LInd].NextSequentialFeedBlockAddress := Pointer(1); {Get the mask to use for finding a medium block suitable for a block pool} LMinimumPoolSize := ((SmallBlockTypes[LInd].BlockSize * MinimumSmallBlocksPerPool @@ -8201,7 +10800,7 @@ procedure InitializeMemoryManager; MediumBlockPoolsCircularList.PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList; MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := @MediumBlockPoolsCircularList; {All medium bins are empty} - for LInd := 0 to high(MediumBlockBins) do + for LInd := 0 to High(MediumBlockBins) do begin LPMediumFreeBlock := @MediumBlockBins[LInd]; LPMediumFreeBlock.PreviousFreeBlock := LPMediumFreeBlock; @@ -8214,14 +10813,14 @@ procedure InitializeMemoryManager; {$ifdef FullDebugMode} {Set up the fake VMT} {Copy the basic info from the TFreedObject class} - System.Move(Pointer(Integer(TFreedObject) + vmtSelfPtr + 4)^, - FreedObjectVMT.VMTData[vmtSelfPtr + 4], vmtParent - vmtSelfPtr); - PCardinal(@FreedObjectVMT.VMTData[vmtSelfPtr])^ := Cardinal(@FreedObjectVMT.VMTMethods[0]); + System.Move(Pointer(PByte(TFreedObject) + vmtSelfPtr + SizeOf(Pointer))^, + FreedObjectVMT.VMTData[vmtSelfPtr + SizeOf(Pointer)], vmtParent - vmtSelfPtr); + PNativeUInt(@FreedObjectVMT.VMTData[vmtSelfPtr])^ := NativeUInt(@FreedObjectVMT.VMTMethods[0]); {Set up the virtual method table} for LInd := 0 to MaxFakeVMTEntries - 1 do begin - PCardinal(@FreedObjectVMT.VMTMethods[low(FreedObjectVMT.VMTMethods) + Integer(LInd * 4)])^ := - Cardinal(@TFreedObject.GetVirtualMethodIndex) + LInd * 6; + PNativeUInt(@FreedObjectVMT.VMTMethods[Low(FreedObjectVMT.VMTMethods) + Integer(LInd * SizeOf(Pointer))])^ := + NativeUInt(@TFreedObject.GetVirtualMethodIndex) + LInd * VMTIndexIncCodeSize; {$ifdef CatchUseOfFreedInterfaces} VMTBadInterface[LInd] := @TFreedObject.InterfaceError; {$endif} @@ -8243,8 +10842,10 @@ procedure InstallMemoryManager; if not FastMMIsInstalled then begin {$ifdef FullDebugMode} - {Try to reserve the 64K block} + {$ifdef 32Bit} + {Try to reserve the 64K block covering address $80808080} ReservedBlock := VirtualAlloc(Pointer(DebugReservedAddress), 65536, MEM_RESERVE, PAGE_NOACCESS); + {$endif} {$endif} {$ifdef MMSharingEnabled} {Build a string identifying the current process} @@ -8268,7 +10869,7 @@ procedure InstallMemoryManager; MappingObjectHandle := OpenFileMappingA(FILE_MAP_READ, False, MappingObjectName); {Is no MM being shared?} {$ifdef EnableBackwardCompatibleMMSharing} - if ((MMWindow or MMWindowBE or MappingObjectHandle) = 0) then + if (MMWindow or MMWindowBE or MappingObjectHandle) = 0 then {$else} if MappingObjectHandle = 0 then {$endif} @@ -8289,13 +10890,13 @@ procedure InstallMemoryManager; WS_POPUP, 0, 0, 0, 0, 0, 0, hInstance, nil); {The window data is a pointer to this memory manager} if MMWindow <> 0 then - SetWindowLongA(MMWindow, GWL_USERDATA, Integer(@NewMemoryManager)); + SetWindowLongA(MMWindow, GWL_USERDATA, NativeInt(@NewMemoryManager)); if MMWindowBE <> 0 then - SetWindowLongA(MMWindowBE, GWL_USERDATA, Integer(@NewMemoryManager)); + SetWindowLongA(MMWindowBE, GWL_USERDATA, NativeInt(@NewMemoryManager)); {$endif} {Create the memory mapped file} - MappingObjectHandle := CreateFileMappingA(INVALID_HANDLE_VALUE, nil, PAGE_READWRITE, 0, 4, - MappingObjectName); + MappingObjectHandle := CreateFileMappingA(INVALID_HANDLE_VALUE, nil, + PAGE_READWRITE, 0, SizeOf(Pointer), MappingObjectName); {Map a view of the memory} LPMapAddress := MapViewOfFile(MappingObjectHandle, FILE_MAP_WRITE, 0, 0, 0); {Set a pointer to the new memory manager} @@ -8531,7 +11132,12 @@ procedure FinalizeMemoryManager; end; end; -initialization +procedure RunInitializationCode; +begin + {Only run this code once during startup.} + if InitializationCodeHasRun then + Exit; + InitializationCodeHasRun := True; {$ifndef BCB} {$ifdef InstallOnlyIfRunningInIDE} if (DebugHook <> 0) and DelphiIsRunning then @@ -8539,8 +11145,9 @@ initialization begin {Initialize all the lookup tables, etc. for the memory manager} InitializeMemoryManager; - {Has another MM been set, or has the Borland MM been used? If so, this file - is not the first unit in the uses clause of the project's .dpr file.} + {Has another MM been set, or has the Embarcadero MM been used? If so, this + file is not the first unit in the uses clause of the project's .dpr + file.} if CheckCanInstallMemoryManager then begin {$ifdef ClearLogFileOnStartup} @@ -8550,10 +11157,14 @@ initialization end; end; {$endif} +end; + +initialization + RunInitializationCode; finalization {$ifndef PatchBCBTerminate} FinalizeMemoryManager; {$endif} -end. +end. \ No newline at end of file diff --git a/Source/System/FastMM4Messages.pas b/Source/System/FastMM4Messages.pas index 11ee3cd..0c9485d 100644 --- a/Source/System/FastMM4Messages.pas +++ b/Source/System/FastMM4Messages.pas @@ -14,15 +14,14 @@ interface const {The name of the debug info support DLL} - FullDebugModeLibraryName = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName32Bit = 'FastMM_FullDebugMode.dll'; + FullDebugModeLibraryName64Bit = 'FastMM_FullDebugMode64.dll'; {Event log strings} LogFileExtension = '_MemoryManager_EventLog.txt'#0; CRLF = #13#10; EventSeparator = '--------------------------------'; {Class name messages} UnknownClassNameMsg = 'Unknown'; - {Stack trace Message} - CurrentStackTraceMsg = #13#10#13#10'The current stack trace leading to this error (return addresses): '; {Memory dump message} MemoryDumpMsg = #13#10#13#10'Current memory dump of 256 bytes starting at pointer address '; {Block Error Messages} @@ -36,18 +35,17 @@ interface BlockHeaderCorruptedMsg = 'The block header has been corrupted. '; BlockFooterCorruptedMsg = 'The block footer has been corrupted. '; FreeModifiedErrorMsg = 'FastMM detected that a block has been modified after being freed. '; + FreeModifiedDetailMsg = #13#10#13#10'Modified byte offsets (and lengths): '; DoubleFreeErrorMsg = 'An attempt has been made to free/reallocate an unallocated block.'; + WrongMMFreeErrorMsg = 'An attempt has been made to free/reallocate a block that was allocated through a different FastMM instance. Check your memory manager sharing settings.'; PreviousBlockSizeMsg = #13#10#13#10'The previous block size was: '; CurrentBlockSizeMsg = #13#10#13#10'The block size is: '; - StackTraceAtPrevAllocMsg = #13#10#13#10'Stack trace of when this block was previously allocated (return addresses):'; - StackTraceAtAllocMsg = #13#10#13#10'Stack trace of when this block was allocated (return addresses):'; PreviousObjectClassMsg = #13#10#13#10'The block was previously used for an object of class: '; CurrentObjectClassMsg = #13#10#13#10'The block is currently used for an object of class: '; PreviousAllocationGroupMsg = #13#10#13#10'The allocation group was: '; PreviousAllocationNumberMsg = #13#10#13#10'The allocation number was: '; CurrentAllocationGroupMsg = #13#10#13#10'The allocation group is: '; CurrentAllocationNumberMsg = #13#10#13#10'The allocation number is: '; - StackTraceAtFreeMsg = #13#10#13#10'Stack trace of when the block was previously freed (return addresses):'; BlockErrorMsgTitle = 'Memory Error Detected'; VirtualMethodErrorHeader = 'FastMM has detected an attempt to call a virtual method on a freed object. An access violation will now be raised in order to abort the current operation.'; InterfaceErrorHeader = 'FastMM has detected an attempt to use an interface of a freed object. An access violation will now be raised in order to abort the current operation.'; @@ -56,8 +54,15 @@ interface VirtualMethodName = #13#10#13#10'Virtual method: '; VirtualMethodOffset = 'Offset +'; VirtualMethodAddress = #13#10#13#10'Virtual method address: '; - StackTraceAtObjectAllocMsg = #13#10#13#10'Stack trace of when the object was allocated (return addresses):'; - StackTraceAtObjectFreeMsg = #13#10#13#10'Stack trace of when the object was subsequently freed (return addresses):'; + {Stack trace messages} + CurrentThreadIDMsg = #13#10#13#10'The current thread ID is 0x'; + CurrentStackTraceMsg = ', and the stack trace (return addresses) leading to this error is:'; + ThreadIDPrevAllocMsg = #13#10#13#10'This block was previously allocated by thread 0x'; + ThreadIDAtAllocMsg = #13#10#13#10'This block was allocated by thread 0x'; + ThreadIDAtFreeMsg = #13#10#13#10'The block was previously freed by thread 0x'; + ThreadIDAtObjectAllocMsg = #13#10#13#10'The object was allocated by thread 0x'; + ThreadIDAtObjectFreeMsg = #13#10#13#10'The object was subsequently freed by thread 0x'; + StackTraceMsg = ', and the stack trace (return addresses) at the time was:'; {Installation Messages} AlreadyInstalledMsg = 'FastMM4 is already installed.'; AlreadyInstalledTitle = 'Already installed.'; @@ -128,4 +133,3 @@ implementation end. - diff --git a/Source/System/FastMM4Options.inc b/Source/System/FastMM4Options.inc index d0db68e..71f5129 100644 --- a/Source/System/FastMM4Options.inc +++ b/Source/System/FastMM4Options.inc @@ -29,21 +29,6 @@ Set the default options for FastMM here. this memory manager and disable this option.} {$define UseCustomVariableSizeMoveRoutines} -{Enable to always assume that the application is multithreaded. Enabling this - option will cause a significant performance hit with single threaded - applications. Enable if you are using multi-threaded third party tools that do - not properly set the IsMultiThread variable. Also set this option if you are - going to share this memory manager between a single threaded application and a - multi-threaded DLL.} -{.$define AssumeMultiThreaded} - -{Enable this option to never put a thread to sleep if a thread contention - occurs. This option will improve performance if the ratio of the number of - active threads to the number of CPU cores is low (typically < 2). With this - option set a thread will enter a "busy waiting" loop instead of relinquishing - its timeslice when a thread contention occurs.} -{.$define NeverSleepOnThreadContention} - {Enable this option to only install FastMM as the memory manager when the application is running inside the Delphi IDE. This is useful when you want to deploy the same EXE that you use for testing, but only want the debugging @@ -51,7 +36,7 @@ Set the default options for FastMM here. the application is not being run inside the IDE debugger, then the default Delphi memory manager will be used (which, since Delphi 2006, is FastMM without FullDebugMode.} -{.$InstallOnlyIfRunningInIDE} +{.$define InstallOnlyIfRunningInIDE} {Due to QC#14070 ("Delphi IDE attempts to free memory after the shutdown code of borlndmm.dll has been called"), FastMM cannot be uninstalled safely when @@ -67,6 +52,33 @@ Set the default options for FastMM here. with the NeverUninstall option.} {.$define UseRuntimePackages} +{-----------------------Concurrency Management Options------------------------} + +{Enable to always assume that the application is multithreaded. Enabling this + option will cause a significant performance hit with single threaded + applications. Enable if you are using multi-threaded third party tools that do + not properly set the IsMultiThread variable. Also set this option if you are + going to share this memory manager between a single threaded application and a + multi-threaded DLL.} +{.$define AssumeMultiThreaded} + +{Enable this option to not call Sleep when a thread contention occurs. This + option will improve performance if the ratio of the number of active threads + to the number of CPU cores is low (typically < 2). With this option set a + thread will usually enter a "busy waiting" loop instead of relinquishing its + timeslice when a thread contention occurs, unless UseSwitchToThread is + also defined (see below) in which case it will call SwitchToThread instead of + Sleep.} +{.$define NeverSleepOnThreadContention} + + {Set this option to call SwitchToThread instead of sitting in a "busy waiting" + loop when a thread contention occurs. This is used in conjunction with the + NeverSleepOnThreadContention option, and has no effect unless + NeverSleepOnThreadContention is also defined. This option may improve + performance with many CPU cores and/or threads of different priorities. Note + that the SwitchToThread API call is only available on Windows 2000 and later.} + {.$define UseSwitchToThread} + {-----------------------------Debugging Options-------------------------------} {Enable this option to suppress the generation of debug info for the @@ -149,6 +161,11 @@ Set the default options for FastMM here. care.} {.$define LoadDebugDLLDynamically} + {.$define DoNotInstallIfDLLMissing} + {If the FastMM_FullDebugMode.dll file is not available then FastMM will not + install itself. No effect unless FullDebugMode and LoadDebugDLLDynamically + are also defined.} + {FastMM usually allocates large blocks from the topmost available address and medium and small blocks from the lowest available address (This reduces fragmentation somewhat). With this option set all blocks are always @@ -157,18 +174,37 @@ Set the default options for FastMM here. help to catch those errors sooner.} {$define AlwaysAllocateTopDown} + {Disables the logging of memory dumps together with the other detail for + memory errors.} + {.$define DisableLoggingOfMemoryDumps} + + {If FastMM encounters a problem with a memory block inside the FullDebugMode + FreeMem handler then an "invalid pointer operation" exception will usually + be raised. If the FreeMem occurs while another exception is being handled + (perhaps in the try.. finally code) then the original exception will be + lost. With this option set FastMM will ignore errors inside FreeMem when an + exception is being handled, thus allowing the original exception to + propagate.} + {$define SuppressFreeMemErrorsInsideException} + + {Adds support for notification of memory manager events in FullDebugMode. + With this define set, the application may assign the OnDebugGetMemFinish, + OnDebugFreeMemStart, etc. callbacks in order to be notified when the + particular memory manager event occurs.} + {.$define FullDebugModeCallBacks} + {---------------------------Memory Leak Reporting-----------------------------} {Set this option to enable reporting of memory leaks. Combine it with the two options below for further fine-tuning.} -{$define EnableMemoryLeakReporting} +{.$define EnableMemoryLeakReporting} {Set this option to suppress the display and logging of expected memory leaks that were registered by pointer. Leaks registered by size or class are often ambiguous, so these expected leaks are always logged to file (in FullDebugMode with the LogMemoryLeakDetailToFile option set) and are never hidden from the leak display if there are more leaks than are expected.} - {$define HideExpectedLeaksRegisteredByPointer} + {.$define HideExpectedLeaksRegisteredByPointer} {Set this option to require the presence of the Delphi IDE to report memory leaks. This option has no effect if the option "EnableMemoryLeakReporting" @@ -179,7 +215,7 @@ Set the default options for FastMM here. report memory leaks. This option has no effect if the option "EnableMemoryLeakReporting" is not also set. Note that this option does not work with libraries, only EXE projects.} - {$define RequireDebuggerPresenceForLeakReporting} + {.$define RequireDebuggerPresenceForLeakReporting} {Set this option to require the presence of debug info ($D+ option) in the compiled unit to perform memory leak checking. This option has no effect if @@ -252,6 +288,22 @@ Set the default options for FastMM here. mechanism used by Delphi 2006 and 2007, as well as older FastMM versions.} {$define EnableBackwardCompatibleMMSharing} +{-----------------------Security Options------------------------} + +{Windows clears physical memory before reusing it in another process. However, + it is not known how quickly this clearing is performed, so it is conceivable + that confidential data may linger in physical memory longer than absolutely + necessary. If you're paranoid about this kind of thing, enable this option to + clear all freed memory before returning it to the operating system. Note that + this incurs a noticeable performance hit.} +{.$define ClearMemoryBeforeReturningToOS} + +{With this option enabled freed memory will immediately be cleared inside the + FreeMem routine. This incurs a big performance hit, but may be worthwhile for + additional peace of mind when working with highly sensitive data. This option + supersedes the ClearMemoryBeforeReturningToOS option.} +{.$define AlwaysClearFreedMemory} + {--------------------------------Option Grouping------------------------------} {Enabling this option enables FullDebugMode, InstallOnlyIfRunningInIDE and @@ -261,6 +313,13 @@ Set the default options for FastMM here. to the non-FullDebugMode FastMM since Delphi 2006.)} {.$define FullDebugModeInIDE} +{Combines the FullDebugMode, LoadDebugDLLDynamically and + DoNotInstallIfDLLMissing options. Consequently FastMM will only be installed + (In FullDebugMode) when the FastMM_FullDebugMode.dll file is available. This + is useful when the same executable will be distributed for both debugging as + well as deployment.} +{.$define FullDebugModeWhenDLLAvailable} + {Group the options you use for release and debug versions below} {$ifdef Release} {Specify the options you use for release versions below} diff --git a/Source/System/FastMMUsageTracker.dfm b/Source/System/FastMMUsageTracker.dfm deleted file mode 100644 index 17e1a60..0000000 --- a/Source/System/FastMMUsageTracker.dfm +++ /dev/null @@ -1,149 +0,0 @@ -object fFastMMUsageTracker: TfFastMMUsageTracker - Left = 259 - Top = 93 - BorderIcons = [biSystemMenu] - BorderStyle = bsSingle - Caption = 'FastMM4 Usage Tracker' - ClientHeight = 566 - ClientWidth = 792 - Color = clBtnFace - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 - Font.Name = 'MS Sans Serif' - Font.Style = [] - OldCreateOrder = False - Position = poScreenCenter - OnClose = FormClose - OnCreate = FormCreate - PixelsPerInch = 96 - TextHeight = 13 - object gbMemoryMap: TGroupBox - Left = 8 - Top = 4 - Width = 301 - Height = 525 - Caption = 'Memory Map' - TabOrder = 0 - object Label1: TLabel - Left = 12 - Top = 496 - Width = 38 - Height = 13 - Caption = 'Address' - end - object Label2: TLabel - Left = 148 - Top = 496 - Width = 25 - Height = 13 - Caption = 'State' - end - object dgMemoryMap: TDrawGrid - Left = 16 - Top = 16 - Width = 277 - Height = 469 - ColCount = 32 - DefaultColWidth = 8 - DefaultRowHeight = 8 - FixedCols = 0 - RowCount = 2048 - FixedRows = 0 - GridLineWidth = 0 - Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine] - ScrollBars = ssVertical - TabOrder = 0 - OnDrawCell = dgMemoryMapDrawCell - OnSelectCell = dgMemoryMapSelectCell - end - object eAddress: TEdit - Left = 56 - Top = 492 - Width = 81 - Height = 21 - Enabled = False - TabOrder = 1 - Text = '$00000000' - end - object eState: TEdit - Left = 184 - Top = 492 - Width = 105 - Height = 21 - Enabled = False - TabOrder = 2 - Text = 'Unallocated' - end - end - object gbBlockStats: TGroupBox - Left = 320 - Top = 4 - Width = 465 - Height = 469 - Caption = 'Block Statistics' - TabOrder = 1 - object sgBlockStatistics: TStringGrid - Left = 12 - Top = 16 - Width = 441 - Height = 441 - DefaultColWidth = 83 - DefaultRowHeight = 17 - Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine] - ScrollBars = ssVertical - TabOrder = 0 - end - end - object bClose: TBitBtn - Left = 708 - Top = 536 - Width = 75 - Height = 25 - Caption = 'Close' - TabOrder = 2 - OnClick = bCloseClick - Glyph.Data = { - 76010000424D7601000000000000760000002800000020000000100000000100 - 04000000000000010000130B0000130B00001000000000000000000000000000 - 800000800000008080008000000080008000808000007F7F7F00BFBFBF000000 - FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333 - 3333333333FFFFF3333333333999993333333333F77777FFF333333999999999 - 33333337777FF377FF3333993370739993333377FF373F377FF3399993000339 - 993337777F777F3377F3393999707333993337F77737333337FF993399933333 - 399377F3777FF333377F993339903333399377F33737FF33377F993333707333 - 399377F333377FF3377F993333101933399377F333777FFF377F993333000993 - 399377FF3377737FF7733993330009993933373FF3777377F7F3399933000399 - 99333773FF777F777733339993707339933333773FF7FFF77333333999999999 - 3333333777333777333333333999993333333333377777333333} - NumGlyphs = 2 - end - object GroupBox1: TGroupBox - Left = 320 - Top = 480 - Width = 465 - Height = 49 - Caption = 'Address Space Usage' - Enabled = False - TabOrder = 3 - object Label3: TLabel - Left = 12 - Top = 20 - Width = 199 - Height = 13 - Caption = 'Total Process Address Space In Use (MB)' - end - object eTotalAddressSpaceInUse: TEdit - Left = 332 - Top = 16 - Width = 121 - Height = 21 - TabOrder = 0 - end - end - object tTimer: TTimer - OnTimer = tTimerTimer - Left = 20 - Top = 24 - end -end diff --git a/Source/System/FastMMUsageTracker.pas b/Source/System/FastMMUsageTracker.pas deleted file mode 100644 index fb85455..0000000 --- a/Source/System/FastMMUsageTracker.pas +++ /dev/null @@ -1,261 +0,0 @@ -unit FastMMUsageTracker; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls, ExtCtrls, Grids, Buttons, FastMM4; - -type - TfFastMMUsageTracker = class(TForm) - gbMemoryMap: TGroupBox; - gbBlockStats: TGroupBox; - tTimer: TTimer; - sgBlockStatistics: TStringGrid; - dgMemoryMap: TDrawGrid; - bClose: TBitBtn; - Label1: TLabel; - eAddress: TEdit; - Label2: TLabel; - eState: TEdit; - GroupBox1: TGroupBox; - Label3: TLabel; - eTotalAddressSpaceInUse: TEdit; - procedure FormClose(Sender: TObject; var Action: TCloseAction); - procedure tTimerTimer(Sender: TObject); - procedure FormCreate(Sender: TObject); - procedure bCloseClick(Sender: TObject); - procedure dgMemoryMapDrawCell(Sender: TObject; ACol, ARow: Integer; - Rect: TRect; State: TGridDrawState); - procedure dgMemoryMapSelectCell(Sender: TObject; ACol, ARow: Integer; - var CanSelect: Boolean); - private - {The current state} - FMemoryManagerState: TMemoryManagerState; - FMemoryMap: TMemoryMap; - public - {Refreshes the display} - procedure RefreshSnapShot; - end; - -function ShowFastMMUsageTracker: TfFastMMUsageTracker; - -{Gets the number of bytes of virtual memory either reserved or committed by this - process} -function GetAddressSpaceUsed: Cardinal; - -implementation - -{$R *.dfm} - -function ShowFastMMUsageTracker: TfFastMMUsageTracker; -begin - Application.CreateForm(TfFastMMUsageTracker, Result); - Result.RefreshSnapShot; - Result.Show; -end; - -function GetAddressSpaceUsed: Cardinal; -var - LMemoryStatus: TMemoryStatus; -begin - {Set the structure size} - LMemoryStatus.dwLength := SizeOf(LMemoryStatus); - {Get the memory status} - GlobalMemoryStatus(LMemoryStatus); - {The result is the total address space less the free address space} - Result := (LMemoryStatus.dwTotalVirtual - LMemoryStatus.dwAvailVirtual) shr 10; -end; - -{ TfUsageTracker } - -procedure TfFastMMUsageTracker.FormClose(Sender: TObject; - var Action: TCloseAction); -begin - Action := caFree; -end; - -procedure TfFastMMUsageTracker.RefreshSnapShot; -var - LInd: integer; - LAllocatedSize, LTotalBlocks, LTotalAllocated, LTotalReserved: Cardinal; -begin - {Get the state} - GetMemoryManagerState(FMemoryManagerState); - GetMemoryMap(FMemoryMap); - dgMemoryMap.Invalidate; - {Set the texts inside the results string grid} - LTotalBlocks := 0; - LTotalAllocated := 0; - LTotalReserved := 0; - for LInd := 0 to high(FMemoryManagerState.SmallBlockTypeStates) do - begin - with FMemoryManagerState.SmallBlockTypeStates[LInd] do - begin - sgBlockStatistics.Cells[1, LInd + 1] := IntToStr(AllocatedBlockCount); - Inc(LTotalBlocks, AllocatedBlockCount); - LAllocatedSize := AllocatedBlockCount * UseableBlockSize; - sgBlockStatistics.Cells[2, LInd + 1] := IntToStr(LAllocatedSize); - Inc(LTotalAllocated, LAllocatedSize); - sgBlockStatistics.Cells[3, LInd + 1] := IntToStr(ReservedAddressSpace); - Inc(LTotalReserved, ReservedAddressSpace); - if ReservedAddressSpace > 0 then - sgBlockStatistics.Cells[4, LInd + 1] := FormatFloat('0.##%', LAllocatedSize/ReservedAddressSpace * 100) - else - sgBlockStatistics.Cells[4, LInd + 1] := 'N/A'; - end; - end; - {Medium blocks} - LInd := length(FMemoryManagerState.SmallBlockTypeStates) + 1; - sgBlockStatistics.Cells[1, LInd] := IntToStr(FMemoryManagerState.AllocatedMediumBlockCount); - Inc(LTotalBlocks, FMemoryManagerState.AllocatedMediumBlockCount); - sgBlockStatistics.Cells[2, LInd] := IntToStr(FMemoryManagerState.TotalAllocatedMediumBlockSize); - Inc(LTotalAllocated, FMemoryManagerState.TotalAllocatedMediumBlockSize); - sgBlockStatistics.Cells[3, LInd] := IntToStr(FMemoryManagerState.ReservedMediumBlockAddressSpace); - Inc(LTotalReserved, FMemoryManagerState.ReservedMediumBlockAddressSpace); - if FMemoryManagerState.ReservedMediumBlockAddressSpace > 0 then - sgBlockStatistics.Cells[4, LInd] := FormatFloat('0.##%', FMemoryManagerState.TotalAllocatedMediumBlockSize/FMemoryManagerState.ReservedMediumBlockAddressSpace * 100) - else - sgBlockStatistics.Cells[4, LInd] := 'N/A'; - {Large blocks} - LInd := length(FMemoryManagerState.SmallBlockTypeStates) + 2; - sgBlockStatistics.Cells[1, LInd] := IntToStr(FMemoryManagerState.AllocatedLargeBlockCount); - Inc(LTotalBlocks, FMemoryManagerState.AllocatedLargeBlockCount); - sgBlockStatistics.Cells[2, LInd] := IntToStr(FMemoryManagerState.TotalAllocatedLargeBlockSize); - Inc(LTotalAllocated, FMemoryManagerState.TotalAllocatedLargeBlockSize); - sgBlockStatistics.Cells[3, LInd] := IntToStr(FMemoryManagerState.ReservedLargeBlockAddressSpace); - Inc(LTotalReserved, FMemoryManagerState.ReservedLargeBlockAddressSpace); - if FMemoryManagerState.ReservedLargeBlockAddressSpace > 0 then - sgBlockStatistics.Cells[4, LInd] := FormatFloat('0.##%', FMemoryManagerState.TotalAllocatedLargeBlockSize/FMemoryManagerState.ReservedLargeBlockAddressSpace * 100) - else - sgBlockStatistics.Cells[4, LInd] := 'N/A'; - {Overall} - LInd := length(FMemoryManagerState.SmallBlockTypeStates) + 3; - sgBlockStatistics.Cells[1, LInd] := IntToStr(LTotalBlocks); - sgBlockStatistics.Cells[2, LInd] := IntToStr(LTotalAllocated); - sgBlockStatistics.Cells[3, LInd] := IntToStr(LTotalReserved); - if LTotalReserved > 0 then - sgBlockStatistics.Cells[4, LInd] := FormatFloat('0.##%', LTotalAllocated/LTotalReserved * 100) - else - sgBlockStatistics.Cells[4, LInd] := 'N/A'; - {Address space usage} - eTotalAddressSpaceInUse.Text := FormatFloat('0.###', GetAddressSpaceUsed / 1024); -end; - -procedure TfFastMMUsageTracker.tTimerTimer(Sender: TObject); -begin - tTimer.Enabled := False; - try - RefreshSnapShot; - finally - tTimer.Enabled := True; - end; -end; - -procedure TfFastMMUsageTracker.FormCreate(Sender: TObject); -var - LInd: integer; -begin - {Set up the row count} - sgBlockStatistics.RowCount := length(FMemoryManagerState.SmallBlockTypeStates) + 4; - {Get the initial snapshot} - RefreshSnapShot; - {Set up the StringGrid columns} - sgBlockStatistics.Cells[0, 0] := 'Block Size'; - sgBlockStatistics.Cells[1, 0] := '# Live Pointers'; - sgBlockStatistics.Cells[2, 0] := 'Live Size'; - sgBlockStatistics.Cells[3, 0] := 'Used Space'; - sgBlockStatistics.Cells[4, 0] := 'Efficiency'; - for LInd := 0 to high(FMemoryManagerState.SmallBlockTypeStates) do - begin - sgBlockStatistics.Cells[0, LInd + 1] := - IntToStr(FMemoryManagerState.SmallBlockTypeStates[LInd].InternalBlockSize) - + '(' + IntToStr(FMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize) + ')'; - end; - sgBlockStatistics.Cells[0, length(FMemoryManagerState.SmallBlockTypeStates) + 1] := 'Medium Blocks'; - sgBlockStatistics.Cells[0, length(FMemoryManagerState.SmallBlockTypeStates) + 2] := 'Large Blocks'; - sgBlockStatistics.Cells[0, length(FMemoryManagerState.SmallBlockTypeStates) + 3] := 'Overall'; -end; - -procedure TfFastMMUsageTracker.bCloseClick(Sender: TObject); -begin - Close; -end; - -procedure TfFastMMUsageTracker.dgMemoryMapDrawCell(Sender: TObject; ACol, - ARow: Integer; Rect: TRect; State: TGridDrawState); -var - LChunkIndex: integer; - LChunkColour: TColor; -begin - {Get the chunk index} - LChunkIndex := ARow * dgMemoryMap.ColCount + ACol; - {Get the correct colour} - case FMemoryMap[LChunkIndex] of - csAllocated: - begin - LChunkColour := $9090ff; - end; - csReserved: - begin - LChunkColour := $90f090; - end; - csSysAllocated: - begin - LChunkColour := $707070; - end; - csSysReserved: - begin - LChunkColour := $c0c0c0; - end - else - begin - {Unallocated} - LChunkColour := $ffffff; - end; - end; - {Draw the chunk background} - dgMemoryMap.Canvas.Brush.Color := LChunkColour; - if State = [] then - begin - dgMemoryMap.Canvas.FillRect(Rect); - end - else - begin - dgMemoryMap.Canvas.Rectangle(Rect); - end; -end; - -procedure TfFastMMUsageTracker.dgMemoryMapSelectCell(Sender: TObject; ACol, - ARow: Integer; var CanSelect: Boolean); -var - LChunkIndex: Cardinal; -begin - LChunkIndex := ARow * dgMemoryMap.ColCount + ACol; - eAddress.Text := Format('$%0.8x', [LChunkIndex shl 16]); - case FMemoryMap[LChunkIndex] of - csAllocated: - begin - eState.Text := 'FastMM Allocated'; - end; - csReserved: - begin - eState.Text := 'FastMM Reserved'; - end; - csSysAllocated: - begin - eState.Text := 'System Allocated'; - end; - csSysReserved: - begin - eState.Text := 'System Reserved'; - end - else - begin - {Unallocated} - eState.Text := 'Unallocated'; - end; - end; -end; - -end. diff --git a/Source/System/LibXmlComps.dcr b/Source/System/LibXmlComps.dcr new file mode 100644 index 0000000..ed9cb54 Binary files /dev/null and b/Source/System/LibXmlComps.dcr differ diff --git a/Source/System/LibXmlParser.pas b/Source/System/LibXmlParser.pas index 2a42e42..b68ee6c 100644 --- a/Source/System/LibXmlParser.pas +++ b/Source/System/LibXmlParser.pas @@ -211,6 +211,12 @@ 2009-12-31 HeySt 1.0.19 Finished work at the attribute value normalization. Delphi 2009/2010 compatibility (no UnicodeString compatibility though, sorry) +2010-10-12 HeySt 1.0.20 Checked Delphi XE compatibility + Included a $DEFINE for FreePascal compatibility + CurContent is not reset to an empty string with every start tag. + I will keep this behaviour so old code doesn't get broken. + In case you need this you can set CurContent yourself at every + start tag. *) @@ -238,6 +244,8 @@ // Managed Code (*$IFDEF MANAGEDCODE *)This code will not compile as Managed Code (*$ENDIF *) (*$IFDEF CLR *) This code will not compile as Managed Code (*$ENDIF *) + (*$IFDEF FPC *) (*$MODE delphi *) (*$ENDIF *) // It's FreePascal + (*$R- Switch Range Checking Off *) (*$B- Switch Complete Boolean Evaluation Off *) @@ -254,11 +262,14 @@ Math; CONST - CVersion = '1.0.19'; // This variable will be updated for every release + CVersion = '1.0.20'; // This variable will be updated for every release // (I hope, I won't forget to do it everytime ...) - CUnknownChar = '¿'; // Replacement for unknown/untransformable character references + CUnknownChar = '?'; // Replacement for unknown/untransformable character references TYPE + TCharType = PAnsiChar; + TStringType = Utf8String; + TPartType = // --- Document Part Types (ptNone, // Nothing ptXmlProlog, // XML Prolog XmlSpec 2.8 / 4.3.1 @@ -290,62 +301,62 @@ TNotationDef = CLASS; TDtdElementRec = RECORD // --- This Record is returned by the DTD parser callback function - Start, Final : PAnsiChar; // Start/End of the Element's Declaration + Start, Final : TCharType; // Start/End of the Element's Declaration CASE ElementType : TDtdElemType OF // Type of the Element deElement, // deAttList : (ElemDef : TElemDef); // deEntity : (EntityDef : TEntityDef); // deNotation : (NotationDef : TNotationDef); // - dePI : (Target : PAnsiChar; // - Content : PAnsiChar; + dePI : (Target : TCharType; // + Content : TCharType; AttrList : TAttrList); - deError : (Pos : PAnsiChar); // Error + deError : (Pos : TCharType); // Error // deComment : ((No additional fields here)); // END; TXmlParser = CLASS // --- Internal Properties and Methods PROTECTED - FBuffer : PAnsiChar; // NIL if there is no buffer available + FBuffer : TCharType; // NIL if there is no buffer available FBufferSize : INTEGER; // 0 if the buffer is not owned by the Document instance FSource : STRING; // Name of Source of document. Filename for Documents loaded with LoadFromFile - FXmlVersion : AnsiString; // XML version from Document header. Default is '1.0' - FEncoding : AnsiString; // Encoding from Document header. Default is 'UTF-8' + FXmlVersion : TStringType; // XML version from Document header. Default is '1.0' + FEncoding : TStringType; // Encoding from Document header. Default is 'UTF-8' FStandalone : BOOLEAN; // Standalone declaration from Document header. Default is 'yes' - FRootName : AnsiString; // Name of the Root Element (= DTD name) - FDtdcFinal : PAnsiChar; // Pointer to the '>' character terminating the DTD declaration + FRootName : TStringType; // Name of the Root Element (= DTD name) + FDtdcFinal : TCharType; // Pointer to the '>' character terminating the DTD declaration FNormalize : BOOLEAN; // If true: Pack Whitespace and don't return empty contents EntityStack : TEntityStack; // Entity Stack for Parameter and General Entities - FCurEncoding : AnsiString; // Current Encoding during parsing (always uppercase) + FCurEncoding : TStringType; // Current Encoding during parsing (always uppercase) PROCEDURE AnalyzeProlog; // Analyze XML Prolog or Text Declaration - PROCEDURE AnalyzeComment (Start : PAnsiChar; VAR Final : PAnsiChar); // Analyze Comments - PROCEDURE AnalyzePI (Start : PAnsiChar; VAR Final : PAnsiChar); // Analyze Processing Instructions (PI) + PROCEDURE AnalyzeComment (Start : TCharType; VAR Final : TCharType); // Analyze Comments + PROCEDURE AnalyzePI (Start : TCharType; VAR Final : TCharType); // Analyze Processing Instructions (PI) PROCEDURE AnalyzeDtdc; // Analyze Document Type Declaration - PROCEDURE AnalyzeDtdElements (Start : PAnsiChar; VAR Final : PAnsiChar); // Analyze DTD declarations + PROCEDURE AnalyzeDtdElements (Start : TCharType; VAR Final : TCharType); // Analyze DTD declarations PROCEDURE AnalyzeTag; // Analyze Start/End/Empty-Element Tags PROCEDURE AnalyzeCData; // Analyze CDATA Sections PROCEDURE AnalyzeText (VAR IsDone : BOOLEAN); // Analyze Text Content between Tags - PROCEDURE AnalyzeElementDecl (Start : PAnsiChar; VAR Final : PAnsiChar); - PROCEDURE AnalyzeAttListDecl (Start : PAnsiChar; VAR Final : PAnsiChar); - PROCEDURE AnalyzeEntityDecl (Start : PAnsiChar; VAR Final : PAnsiChar); - PROCEDURE AnalyzeNotationDecl (Start : PAnsiChar; VAR Final : PAnsiChar); + PROCEDURE AnalyzeElementDecl (Start : TCharType; VAR Final : TCharType); + PROCEDURE AnalyzeAttListDecl (Start : TCharType; VAR Final : TCharType); + PROCEDURE AnalyzeEntityDecl (Start : TCharType; VAR Final : TCharType); + PROCEDURE AnalyzeNotationDecl (Start : TCharType; VAR Final : TCharType); - PROCEDURE PushPE (VAR Start : PAnsiChar); - PROCEDURE ReplaceCharacterEntities (VAR Str : AnsiString); - PROCEDURE ReplaceParameterEntities (VAR Str : AnsiString); + PROCEDURE PushPE (VAR Start : TCharType); + PROCEDURE ReplaceCharacterEntities (VAR Str : TStringType); + PROCEDURE ReplaceParameterEntities (VAR Str : TStringType); - FUNCTION GetDocBuffer : PAnsiChar; // Returns FBuffer or a pointer to a NUL char if Buffer is empty + FUNCTION GetDocBuffer : TCharType; // Returns FBuffer or a pointer to a NUL char if Buffer is empty PUBLIC // --- Document Properties - PROPERTY XmlVersion : AnsiString READ FXmlVersion; // XML version from the Document Prolog - PROPERTY Encoding : AnsiString READ FEncoding; // Document Encoding from Prolog + PROPERTY XmlVersion : TStringType READ FXmlVersion; // XML version from the Document Prolog + PROPERTY Encoding : TStringType READ FEncoding; // Document Encoding from Prolog PROPERTY Standalone : BOOLEAN READ FStandalone; // Standalone Declaration from Prolog - PROPERTY RootName : AnsiString READ FRootName; // Name of the Root Element + PROPERTY RootName : TStringType READ FRootName; // Name of the Root Element PROPERTY Normalize : BOOLEAN READ FNormalize WRITE FNormalize; // True if Content is to be normalized PROPERTY Source : STRING READ FSource; // Name of Document Source (Filename) - PROPERTY DocBuffer : PAnsiChar READ GetDocBuffer; // Returns document buffer + PROPERTY DocBuffer : TCharType READ GetDocBuffer; // Returns document buffer PUBLIC // --- DTD Objects Elements : TElemList; // Elements: List of TElemDef (contains Attribute Definitions) Entities : TNvpList; // General Entities: List of TEntityDef @@ -359,28 +370,28 @@ FUNCTION LoadFromFile (Filename : STRING; FileMode : INTEGER = fmOpenRead OR fmShareDenyNone) : BOOLEAN; // Loads Document from given file - FUNCTION LoadFromBuffer (Buffer : PAnsiChar) : BOOLEAN; // Loads Document from another buffer - PROCEDURE SetBuffer (Buffer : PAnsiChar); // References another buffer + FUNCTION LoadFromBuffer (Buffer : TCharType) : BOOLEAN; // Loads Document from another buffer + PROCEDURE SetBuffer (Buffer : TCharType); // References another buffer PROCEDURE Clear; // Clear Document PUBLIC // --- Scanning through the document CurPartType : TPartType; // Current Type - CurName : AnsiString; // Current Name - CurContent : AnsiString; // Current Normalized Content - CurStart : PAnsiChar; // Current First character - CurFinal : PAnsiChar; // Current Last character + CurName : TStringType; // Current Name + CurContent : TStringType; // Current Normalized Content + CurStart : TCharType; // Current First character + CurFinal : TCharType; // Current Last character CurAttr : TAttrList; // Current Attribute List - PROPERTY CurEncoding : AnsiString READ FCurEncoding; // Current Encoding (always uppercase) + PROPERTY CurEncoding : TStringType READ FCurEncoding; // Current Encoding (always uppercase) PROCEDURE StartScan; FUNCTION Scan : BOOLEAN; // --- Events / Callbacks FUNCTION LoadExternalEntity (SystemId, PublicId, - Notation : AnsiString) : TXmlParser; VIRTUAL; - FUNCTION TranslateEncoding (CONST Source : AnsiString) : AnsiString; VIRTUAL; + Notation : TStringType) : TXmlParser; VIRTUAL; + FUNCTION TranslateEncoding (CONST Source : TStringType) : TStringType; VIRTUAL; FUNCTION TranslateCharacter (CONST UnicodeValue : INTEGER; - CONST UnknownChar : AnsiString = CUnknownChar) : AnsiString; VIRTUAL; + CONST UnknownChar : TStringType = CUnknownChar) : TStringType; VIRTUAL; PROCEDURE DtdElementFound (DtdElementRec : TDtdElementRec); VIRTUAL; END; @@ -426,18 +437,18 @@ (*$ENDIF *) TNvpNode = CLASS // Name-Value Pair Node - Name : AnsiString; - Value : AnsiString; - CONSTRUCTOR Create (TheName : AnsiString = ''; TheValue : AnsiString = ''); + Name : TStringType; + Value : TStringType; + CONSTRUCTOR Create (TheName : TStringType = ''; TheValue : TStringType = ''); END; TNvpList = CLASS (TObjectList) // Name-Value Pair List PROCEDURE Add (Node : TNvpNode); - FUNCTION Node (Name : AnsiString) : TNvpNode; OVERLOAD; + FUNCTION Node (Name : TStringType) : TNvpNode; OVERLOAD; FUNCTION Node (Index : INTEGER) : TNvpNode; OVERLOAD; - FUNCTION Value (Name : AnsiString) : AnsiString; OVERLOAD; - FUNCTION Value (Index : INTEGER) : AnsiString; OVERLOAD; - FUNCTION Name (Index : INTEGER) : AnsiString; + FUNCTION Value (Name : TStringType) : TStringType; OVERLOAD; + FUNCTION Value (Index : INTEGER) : TStringType; OVERLOAD; + FUNCTION Name (Index : INTEGER) : TStringType; END; TAttr = CLASS (TNvpNode) // Attribute of a Start-Tag or Empty-Element-Tag @@ -446,7 +457,7 @@ END; TAttrList = CLASS (TNvpList) // List of Attributes - PROCEDURE Analyze (Start : PAnsiChar; VAR Final : PAnsiChar); + PROCEDURE Analyze (Start : TCharType; VAR Final : TCharType); END; TEntityStack = CLASS (TObjectList) // Stack where current position is stored before parsing entities @@ -454,37 +465,37 @@ Owner : TXmlParser; PUBLIC CONSTRUCTOR Create (TheOwner : TXmlParser); - PROCEDURE Push (LastPos : PAnsiChar); OVERLOAD; - PROCEDURE Push (Instance : TObject; LastPos : PAnsiChar); OVERLOAD; - FUNCTION Pop : PAnsiChar; // Returns next char or NIL if EOF is reached. Frees Instance. + PROCEDURE Push (LastPos : TCharType); OVERLOAD; + PROCEDURE Push (Instance : TObject; LastPos : TCharType); OVERLOAD; + FUNCTION Pop : TCharType; // Returns next char or NIL if EOF is reached. Frees Instance. END; TAttrDef = CLASS (TNvpNode) // Represents a Win-12xx - - WIN1250_UNICODE : ARRAY [$00..$FF] OF WORD = ( // Windows-1250: Latin-2 = Central and East Europe - $0000, $0001, $0002, $0003, $0004, $0005, $0006, $0007, $0008, $0009, - $000A, $000B, $000C, $000D, $000E, $000F, $0010, $0011, $0012, $0013, - $0014, $0015, $0016, $0017, $0018, $0019, $001A, $001B, $001C, $001D, - $001E, $001F, $0020, $0021, $0022, $0023, $0024, $0025, $0026, $0027, - $0028, $0029, $002A, $002B, $002C, $002D, $002E, $002F, $0030, $0031, - $0032, $0033, $0034, $0035, $0036, $0037, $0038, $0039, $003A, $003B, - $003C, $003D, $003E, $003F, $0040, $0041, $0042, $0043, $0044, $0045, - $0046, $0047, $0048, $0049, $004A, $004B, $004C, $004D, $004E, $004F, - $0050, $0051, $0052, $0053, $0054, $0055, $0056, $0057, $0058, $0059, - $005A, $005B, $005C, $005D, $005E, $005F, $0060, $0061, $0062, $0063, - $0064, $0065, $0066, $0067, $0068, $0069, $006A, $006B, $006C, $006D, - $006E, $006F, $0070, $0071, $0072, $0073, $0074, $0075, $0076, $0077, - $0078, $0079, $007A, $007B, $007C, $007D, $007E, $007F, - - $20AC, $0081, $201A, $0083, $201E, $2026, $2020, $2021, $0088, $2030, - $0160, $2039, $015A, $0164, $017D, $0179, $0090, $2018, $2019, $201C, - $201D, $2022, $2013, $2014, $0098, $2122, $0161, $203A, $015B, $0165, - $017E, $017A, $00A0, $02C7, $02D8, $0141, $00A4, $0104, $00A6, $00A7, - $00A8, $00A9, $015E, $00AB, $00AC, $00AD, $00AE, $017B, $00B0, $00B1, - $02DB, $0142, $00B4, $00B5, $00B6, $00B7, $00B8, $0105, $015F, $00BB, - $013D, $02DD, $013E, $017C, $0154, $00C1, $00C2, $0102, $00C4, $0139, - $0106, $00C7, $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E, - $0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7, $0158, $016E, - $00DA, $0170, $00DC, $00DD, $0162, $00DF, $0155, $00E1, $00E2, $0103, - $00E4, $013A, $0107, $00E7, $010D, $00E9, $0119, $00EB, $011B, $00ED, - $00EE, $010F, $0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7, - $0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9); - - WIN1251_UNICODE : ARRAY [$00..$FF] OF WORD = ( // Windows-1251 = Cyrillic = Russian, Ucrainian - $0000, $0001, $0002, $0003, $0004, $0005, $0006, $0007, $0008, $0009, - $000A, $000B, $000C, $000D, $000E, $000F, $0010, $0011, $0012, $0013, - $0014, $0015, $0016, $0017, $0018, $0019, $001A, $001B, $001C, $001D, - $001E, $001F, $0020, $0021, $0022, $0023, $0024, $0025, $0026, $0027, - $0028, $0029, $002A, $002B, $002C, $002D, $002E, $002F, $0030, $0031, - $0032, $0033, $0034, $0035, $0036, $0037, $0038, $0039, $003A, $003B, - $003C, $003D, $003E, $003F, $0040, $0041, $0042, $0043, $0044, $0045, - $0046, $0047, $0048, $0049, $004A, $004B, $004C, $004D, $004E, $004F, - $0050, $0051, $0052, $0053, $0054, $0055, $0056, $0057, $0058, $0059, - $005A, $005B, $005C, $005D, $005E, $005F, $0060, $0061, $0062, $0063, - $0064, $0065, $0066, $0067, $0068, $0069, $006A, $006B, $006C, $006D, - $006E, $006F, $0070, $0071, $0072, $0073, $0074, $0075, $0076, $0077, - $0078, $0079, $007A, $007B, $007C, $007D, $007E, $007F, - - $0402, $0403, $201A, $0453, $201E, $2026, $2020, $2021, $20AC, $2030, - $0409, $2039, $040A, $040C, $040B, $040F, $0452, $2018, $2019, $201C, - $201D, $2022, $2013, $2014, $0098, $2122, $0459, $203A, $045A, $045C, - $045B, $045F, $00A0, $040E, $045E, $0408, $00A4, $0490, $00A6, $00A7, - $0401, $00A9, $0404, $00AB, $00AC, $00AD, $00AE, $0407, $00B0, $00B1, - $0406, $0456, $0491, $00B5, $00B6, $00B7, $0451, $2116, $0454, $00BB, - $0458, $0405, $0455, $0457, $0410, $0411, $0412, $0413, $0414, $0415, - $0416, $0417, $0418, $0419, $041A, $041B, $041C, $041D, $041E, $041F, - $0420, $0421, $0422, $0423, $0424, $0425, $0426, $0427, $0428, $0429, - $042A, $042B, $042C, $042D, $042E, $042F, $0430, $0431, $0432, $0433, - $0434, $0435, $0436, $0437, $0438, $0439, $043A, $043B, $043C, $043D, - $043E, $043F, $0440, $0441, $0442, $0443, $0444, $0445, $0446, $0447, - $0448, $0449, $044A, $044B, $044C, $044D, $044E, $044F); - - WIN1252_UNICODE : ARRAY [$00..$FF] OF WORD = ( // Windows-1252 = Latin-1 = West Europe, Americas - $0000, $0001, $0002, $0003, $0004, $0005, $0006, $0007, $0008, $0009, - $000A, $000B, $000C, $000D, $000E, $000F, $0010, $0011, $0012, $0013, - $0014, $0015, $0016, $0017, $0018, $0019, $001A, $001B, $001C, $001D, - $001E, $001F, $0020, $0021, $0022, $0023, $0024, $0025, $0026, $0027, - $0028, $0029, $002A, $002B, $002C, $002D, $002E, $002F, $0030, $0031, - $0032, $0033, $0034, $0035, $0036, $0037, $0038, $0039, $003A, $003B, - $003C, $003D, $003E, $003F, $0040, $0041, $0042, $0043, $0044, $0045, - $0046, $0047, $0048, $0049, $004A, $004B, $004C, $004D, $004E, $004F, - $0050, $0051, $0052, $0053, $0054, $0055, $0056, $0057, $0058, $0059, - $005A, $005B, $005C, $005D, $005E, $005F, $0060, $0061, $0062, $0063, - $0064, $0065, $0066, $0067, $0068, $0069, $006A, $006B, $006C, $006D, - $006E, $006F, $0070, $0071, $0072, $0073, $0074, $0075, $0076, $0077, - $0078, $0079, $007A, $007B, $007C, $007D, $007E, $007F, - - $20AC, $0081, $201A, $0192, $201E, $2026, $2020, $2021, $02C6, $2030, - $0160, $2039, $0152, $008D, $017D, $008F, $0090, $2018, $2019, $201C, - $201D, $2022, $2013, $2014, $02DC, $2122, $0161, $203A, $0153, $009D, - $017E, $0178, $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, $00B0, $00B1, - $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, $00B8, $00B9, $00BA, $00BB, - $00BC, $00BD, $00BE, $00BF, $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, - $00C6, $00C7, $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, $00D8, $00D9, - $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, $00E0, $00E1, $00E2, $00E3, - $00E4, $00E5, $00E6, $00E7, $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, - $00EE, $00EF, $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF); - - -(* UTF-8 (somewhat simplified) - ----- - Character Range Byte sequence - --------------- -------------------------- (x=Bits from original character) - $0000..$007F 0xxxxxxx - $0080..$07FF 110xxxxx 10xxxxxx - $8000..$FFFF 1110xxxx 10xxxxxx 10xxxxxx - > $FFFF Not necessary for WIN12xx - - Example - -------- - Transforming the Unicode character U+00E4 LATIN SMALL LETTER A WITH DIAERESIS ("ä"): - ISO-8859-1, Decimal 228 - Win1252, Hex $E4 - ANSI Bin 1110 0100 - abcd efgh - UTF-8 Binary 1100xxab 10cdefgh - Binary 11000011 10100100 - Hex $C3 $A4 - Decimal 195 164 - ANSI à ¤ *) - - -FUNCTION AnsiToUtf8 (Source : ANSISTRING) : AnsiString; - (* Converts the given Windows ANSI (Windows-1252) String to UTF-8. *) -VAR - I : INTEGER; // Loop counter - U : WORD; // Current Unicode value - Len : INTEGER; // Current real length of "Result" string -BEGIN - SetLength (Result, Length (Source) * 3); // Worst case - Len := 0; - FOR I := 1 TO Length (Source) DO BEGIN - U := WIN1252_UNICODE [ORD (Source [I])]; - CASE U OF - $0000..$007F : BEGIN - INC (Len); - Result [Len] := AnsiChar (U); - END; - $0080..$07FF : BEGIN - INC (Len); - Result [Len] := AnsiChar ($C0 OR (U SHR 6)); - INC (Len); - Result [Len] := AnsiChar ($80 OR (U AND $3F)); - END; - $0800..$FFFF : BEGIN - INC (Len); - Result [Len] := AnsiChar ($E0 OR (U SHR 12)); - INC (Len); - Result [Len] := AnsiChar ($80 OR ((U SHR 6) AND $3F)); - INC (Len); - Result [Len] := AnsiChar ($80 OR (U AND $3F)); - END; - END; - END; - SetLength (Result, Len); -END; - - -FUNCTION Utf8ToAnsi (Source : AnsiString; UnknownChar : ANSICHAR = CUnknownChar) : ANSISTRING; - (* Converts the given UTF-8 String to Windows ANSI (Windows-1252). - If a character can not be converted, the "UnknownChar" is inserted. *) -VAR - SourceLen : INTEGER; // Length of Source string - I, K : INTEGER; - A : BYTE; // Current ANSI character value - U : WORD; - Ch : ANSICHAR; // Dest char - Len : INTEGER; // Current real length of "Result" string -BEGIN - SourceLen := Length (Source); - SetLength (Result, SourceLen); // Enough room to live - Len := 0; - I := 1; - WHILE I <= SourceLen DO BEGIN - A := ORD (Source [I]); - IF A < $80 THEN BEGIN // Range $0000..$007F - INC (Len); - Result [Len] := Source [I]; - INC (I); - END - ELSE BEGIN // Determine U, Inc I - IF (A AND $E0 = $C0) AND (I < SourceLen) THEN BEGIN // Range $0080..$07FF - U := (WORD (A AND $1F) SHL 6) OR (ORD (Source [I+1]) AND $3F); - INC (I, 2); - END - ELSE IF (A AND $F0 = $E0) AND (I < SourceLen-1) THEN BEGIN // Range $0800..$FFFF - U := (WORD (A AND $0F) SHL 12) OR - (WORD (ORD (Source [I+1]) AND $3F) SHL 6) OR - ( ORD (Source [I+2]) AND $3F); - INC (I, 3); - END - ELSE BEGIN // Unknown/unsupported - INC (I); - FOR K := 7 DOWNTO 0 DO - IF A AND (1 SHL K) = 0 THEN BEGIN - INC (I, (A SHR (K+1))-1); - BREAK; - END; - U := WIN1252_UNICODE [ORD (UnknownChar)]; - END; - Ch := UnknownChar; // Retrieve ANSI char - if U <= $7F then - Ch := AnsiChar (U) - else - FOR A := $80 TO $FF DO - IF WIN1252_UNICODE [A] = U THEN BEGIN - Ch := ANSICHAR (A); - BREAK; - END; - INC (Len); - Result [Len] := Ch; - END; - END; - SetLength (Result, Len); -END; - - (* =============================================================================================== "Special" Helper Functions @@ -861,7 +653,7 @@ =============================================================================================== --> Just move this line below the StrScan function --> *) -FUNCTION StrPos (CONST Str, SearchStr : PAnsiChar) : PAnsiChar; +FUNCTION StrPos (CONST Str, SearchStr : TCharType) : TCharType; // Same functionality as SysUtils.StrPos VAR First : ANSICHAR; @@ -882,7 +674,7 @@ END; -FUNCTION StrScan (CONST Start : PAnsiChar; CONST Ch : ANSICHAR) : PAnsiChar; +FUNCTION StrScan (CONST Start : TCharType; CONST Ch : ANSICHAR) : TCharType; // Same functionality as SysUtils.StrScan BEGIN Result := Start; @@ -902,7 +694,7 @@ =============================================================================================== *) -FUNCTION DelChars (Source : AnsiString; CharsToDelete : TCharset) : AnsiString; +FUNCTION DelChars (Source : TStringType; CharsToDelete : TCharset) : TStringType; // Delete all "CharsToDelete" from the string VAR I : INTEGER; @@ -913,7 +705,7 @@ Delete (Result, I, 1); END; -FUNCTION TrimWs (Source : AnsiString) : AnsiString; +FUNCTION TrimWs (Source : TStringType) : TStringType; // Trimms off Whitespace characters from both ends of the string VAR I : INTEGER; @@ -932,7 +724,7 @@ END; -FUNCTION TrimAndPackSpace (Source : AnsiString) : AnsiString; +FUNCTION TrimAndPackSpace (Source : TStringType) : TStringType; // Trim and pack contiguous space (#x20) characters // Needed for attribute value normalization of non-CDATA attributes (XMLSpec 3.3.3) VAR @@ -961,7 +753,7 @@ END; -FUNCTION ConvertWs (Source: AnsiString; PackWs: BOOLEAN) : AnsiString; +FUNCTION ConvertWs (Source: TStringType; PackWs: BOOLEAN) : TStringType; // Converts all Whitespace characters to the Space #x20 character // If "PackWs" is true, contiguous Whitespace characters are packed to one VAR @@ -978,25 +770,25 @@ -PROCEDURE SetStringSF (VAR S : AnsiString; BufferStart, BufferFinal : PAnsiChar); +PROCEDURE SetStringSF (VAR S : TStringType; BufferStart, BufferFinal : TCharType); BEGIN SetString (S, BufferStart, BufferFinal-BufferStart+1); END; -FUNCTION StrLPas (Start : PAnsiChar; Len : INTEGER) : AnsiString; +FUNCTION StrLPas (Start : TCharType; Len : INTEGER) : TStringType; BEGIN SetString (Result, Start, Len); END; -FUNCTION StrSFPas (Start, Finish : PAnsiChar) : AnsiString; +FUNCTION StrSFPas (Start, Finish : TCharType) : TStringType; BEGIN SetString (Result, Start, Finish-Start+1); END; -FUNCTION StrScanE (CONST Source : PAnsiChar; CONST CharToScanFor : ANSICHAR) : PAnsiChar; +FUNCTION StrScanE (CONST Source : TCharType; CONST CharToScanFor : ANSICHAR) : TCharType; // If "CharToScanFor" is not found, StrScanE returns the last char of the // buffer instead of NIL BEGIN @@ -1006,7 +798,7 @@ END; -PROCEDURE ExtractName (Start : PAnsiChar; Terminators : TCharset; VAR Final : PAnsiChar); +PROCEDURE ExtractName (Start : TCharType; Terminators : TCharset; VAR Final : TCharType); (* Extracts the complete Name beginning at "Start". It is assumed that the name is contained in Markup, so the '>' character is always a Termination. @@ -1022,7 +814,7 @@ END; -PROCEDURE ExtractQuote (Start : PAnsiChar; VAR Content : AnsiString; VAR Final : PAnsiChar); +PROCEDURE ExtractQuote (Start : TCharType; VAR Content : TStringType; VAR Final : TCharType); (* Extract a string which is contained in single or double Quotes. Start: IN Pointer to opening quote Content: OUT The quoted string @@ -1056,8 +848,8 @@ TYPE TEntityStackNode = CLASS Instance : TObject; - Encoding : AnsiString; - LastPos : PAnsiChar; + Encoding : TStringType; + LastPos : TCharType; END; (* @@ -1079,13 +871,13 @@ END; -PROCEDURE TEntityStack.Push (LastPos : PAnsiChar); +PROCEDURE TEntityStack.Push (LastPos : TCharType); BEGIN Push (NIL, LastPos); END; -PROCEDURE TEntityStack.Push (Instance : TObject; LastPos : PAnsiChar); +PROCEDURE TEntityStack.Push (Instance : TObject; LastPos : TCharType); VAR ESN : TEntityStackNode; BEGIN @@ -1097,7 +889,7 @@ END; -FUNCTION TEntityStack.Pop : PAnsiChar; +FUNCTION TEntityStack.Pop : TCharType; VAR ESN : TEntityStackNode; BEGIN @@ -1128,13 +920,13 @@ TYPE TExternalID = CLASS - PublicId : AnsiString; - SystemId : AnsiString; - Final : PAnsiChar; - CONSTRUCTOR Create (Start : PAnsiChar); + PublicId : TStringType; + SystemId : TStringType; + Final : TCharType; + CONSTRUCTOR Create (Start : TCharType); END; -CONSTRUCTOR TExternalID.Create (Start : PAnsiChar); +CONSTRUCTOR TExternalID.Create (Start : TCharType); BEGIN INHERITED Create; Final := Start; @@ -1266,7 +1058,7 @@ END; -FUNCTION TXmlParser.LoadFromBuffer (Buffer : PAnsiChar) : BOOLEAN; +FUNCTION TXmlParser.LoadFromBuffer (Buffer : TCharType) : BOOLEAN; // Loads Document from another buffer // Returns TRUE if successful // The "Source" property becomes '' if successful @@ -1286,7 +1078,7 @@ END; -PROCEDURE TXmlParser.SetBuffer (Buffer : PAnsiChar); // References another buffer +PROCEDURE TXmlParser.SetBuffer (Buffer : TCharType); // References another buffer BEGIN Clear; FBuffer := Buffer; @@ -1364,7 +1156,7 @@ PROCEDURE TXmlParser.AnalyzeProlog; // Analyze XML Prolog or Text Declaration VAR - F : PAnsiChar; + F : TCharType; BEGIN CurAttr.Analyze (CurStart+5, F); IF EntityStack.Count = 0 THEN BEGIN @@ -1379,14 +1171,14 @@ FCurEncoding := CurAttr.Value ('encoding'); IF FCurEncoding = '' THEN FCurEncoding := 'UTF-8'; // Default XML Encoding is UTF-8 - AnsiStrupper (PAnsiChar (FCurEncoding)); + AnsiStrupper (TCharType (FCurEncoding)); CurPartType := ptXmlProlog; CurName := ''; CurContent := ''; END; -PROCEDURE TXmlParser.AnalyzeComment (Start : PAnsiChar; VAR Final : PAnsiChar); +PROCEDURE TXmlParser.AnalyzeComment (Start : TCharType; VAR Final : TCharType); // Analyze Comments BEGIN Final := StrPos (Start+4, '-->'); @@ -1397,10 +1189,10 @@ END; -PROCEDURE TXmlParser.AnalyzePI (Start : PAnsiChar; VAR Final : PAnsiChar); +PROCEDURE TXmlParser.AnalyzePI (Start : TCharType; VAR Final : TCharType); // Analyze Processing Instructions (PI) VAR - F : PAnsiChar; + F : TCharType; BEGIN CurPartType := ptPI; Final := StrPos (Start+2, '?>'); @@ -1431,7 +1223,7 @@ TPhase = (phName, phDtd, phInternal, phFinishing); VAR Phase : TPhase; - F : PAnsiChar; + F : TCharType; ExternalID : TExternalID; ExternalDTD : TXmlParser; DER : TDtdElementRec; @@ -1521,7 +1313,7 @@ END; -PROCEDURE TXmlParser.AnalyzeDtdElements (Start : PAnsiChar; VAR Final : PAnsiChar); +PROCEDURE TXmlParser.AnalyzeDtdElements (Start : TCharType; VAR Final : TCharType); // Analyze the "Elements" of a DTD contained in the external or // internal DTD subset. VAR @@ -1550,8 +1342,8 @@ DER.ElementType := dePI; DER.Start := Final; AnalyzePI (Final, Final); - DER.Target := PAnsiChar (CurName); - DER.Content := PAnsiChar (CurContent); + DER.Target := TCharType (CurName); + DER.Content := TCharType (CurContent); DER.AttrList := CurAttr; DER.Final := Final; DtdElementFound (DER); @@ -1615,18 +1407,18 @@ non-validating processor as if declared CDATA. *) - function NormalizeAttrValStr (Str : AnsiString; IsEncoded : boolean) : AnsiString; + function NormalizeAttrValStr (Str : TStringType; IsEncoded : boolean) : TStringType; // Delivers a normalized and encoded representation of the attribute value in Str. // Will be called recursively for parsed general entities. // When IsEncoded is TRUE, the string in Str is already encoded in the target charset. var i : integer; EntLen : integer; - PSemi : PAnsiChar; + PSemi : TCharType; Len : integer; EntityDef : TEntityDef; - EntName : AnsiString; - Repl : AnsiString; // Replacement + EntName : TStringType; + Repl : TStringType; // Replacement ExternalEntity : TXmlParser; EncLen : integer; // Length of untranscoded part begin @@ -1646,10 +1438,10 @@ EncLen := 0; end; '&' : begin - PSemi := StrScan (PAnsiChar (Str) + i + 1, ';'); + PSemi := StrScan (TCharType (Str) + i + 1, ';'); Repl := ''; if PSemi <> NIL then begin - EntLen := PSemi - PAnsiChar (Str) - i; + EntLen := PSemi - TCharType (Str) - i; EntName := Copy (Str, i + 1, EntLen); IF EntName = 'lt' THEN Repl := '<' ELSE IF EntName = 'gt' THEN Repl := '>' @@ -1658,8 +1450,8 @@ ELSE IF EntName = 'quot' THEN Repl := '"' ELSE IF Copy (EntName, 1, 1) = '#' THEN BEGIN // Character Reference IF EntName [2] = 'x' - THEN Repl := TranslateCharacter (StrToIntDef ('$' + Copy (string (EntName), 3, MaxInt), ord (CUnknownChar))) - ELSE Repl := TranslateCharacter (StrToIntDef ( Copy (string (EntName), 2, MaxInt), ord (CUnknownChar))); + THEN Repl := TranslateCharacter(StrToIntDef ('$' + Copy (string (EntName), 3, MaxInt), ord (CUnknownChar))) + ELSE Repl := TranslateCharacter(StrToIntDef ( Copy (string (EntName), 2, MaxInt), ord (CUnknownChar))); END ELSE BEGIN // Resolve General Entity Reference EntityDef := TEntityDef (Entities.Node (EntName)); @@ -1710,7 +1502,7 @@ end; VAR - S, F : PAnsiChar; + S, F : TCharType; Attr : TAttr; ElemDef : TElemDef; AttrDef : TAttrDef; @@ -1770,7 +1562,7 @@ CurFinal := StrPos (CurStart, CDEnd); IF CurFinal = NIL THEN BEGIN CurFinal := StrEnd (CurStart)-1; - CurContent := TranslateEncoding (StrPas (CurStart+Length (CDStart))); + CurContent := TranslateEncoding (TStringType(StrPas (CurStart+Length (CDStart)))); END ELSE BEGIN SetStringSF (CurContent, CurStart+Length (CDStart), CurFinal-1); @@ -1795,8 +1587,8 @@ IN "CurFinal" points to the ampersand OUT "CurFinal" points to the first character after the semi-colon ';' *) VAR - P : PAnsiChar; - Name : AnsiString; + P : TCharType; + Name : TStringType; EntityDef : TEntityDef; ExternalEntity : TXmlParser; BEGIN @@ -1825,7 +1617,7 @@ IF EntityDef <> NIL THEN BEGIN IF EntityDef.Value <> '' THEN BEGIN EntityStack.Push (P+1); - CurFinal := PAnsiChar (EntityDef.Value); + CurFinal := TCharType (EntityDef.Value); END ELSE BEGIN ExternalEntity := LoadExternalEntity (EntityDef.SystemId, EntityDef.PublicId, EntityDef.NotationName); @@ -1883,7 +1675,7 @@ END; -PROCEDURE TXmlParser.AnalyzeElementDecl (Start : PAnsiChar; VAR Final : PAnsiChar); +PROCEDURE TXmlParser.AnalyzeElementDecl (Start : TCharType; VAR Final : TCharType); (* Parse ' character XmlSpec 3.2: @@ -1908,7 +1700,7 @@ VAR Element : TElemDef; Elem2 : TElemDef; - F : PAnsiChar; + F : TCharType; DER : TDtdElementRec; BEGIN Element := TElemDef.Create; @@ -1922,7 +1714,7 @@ Final := F; F := StrScan (Final+1, '>'); IF F = NIL THEN BEGIN - Element.Definition := AnsiString (Final); + Element.Definition := TStringType (Final); Final := StrEnd (Final); BREAK; END @@ -1954,7 +1746,7 @@ END; -PROCEDURE TXmlParser.AnalyzeAttListDecl (Start : PAnsiChar; VAR Final : PAnsiChar); +PROCEDURE TXmlParser.AnalyzeAttListDecl (Start : TCharType; VAR Final : TCharType); (* Parse ' character XmlSpec 3.3: @@ -1982,12 +1774,12 @@ TPhase = (phElementName, phName, phType, phNotationContent, phDefault); VAR Phase : TPhase; - F : PAnsiChar; - ElementName : AnsiString; + F : TCharType; + ElementName : TStringType; ElemDef : TElemDef; AttrDef : TAttrDef; AttrDef2 : TAttrDef; - Strg : AnsiString; + Strg : TStringType; DER : TDtdElementRec; BEGIN Final := Start + 9; // The character after NIL THEN SetStringSF (AttrDef.TypeDef, Final+1, F-1) - ELSE AttrDef.TypeDef := AnsiString (Final+1); + ELSE AttrDef.TypeDef := TStringType (Final+1); AttrDef.TypeDef := DelChars (AttrDef.TypeDef, CWhitespace); AttrDef.AttrType := atEnumeration; ReplaceParameterEntities (AttrDef.TypeDef); @@ -2071,7 +1863,7 @@ IF F <> NIL THEN SetStringSF (AttrDef.Notations, Final+1, F-1) ELSE BEGIN - AttrDef.Notations := AnsiString (Final+1); + AttrDef.Notations := TStringType (Final+1); Final := StrEnd (Final); END; ReplaceParameterEntities (AttrDef.Notations); @@ -2113,7 +1905,7 @@ END; -PROCEDURE TXmlParser.AnalyzeEntityDecl (Start : PAnsiChar; VAR Final : PAnsiChar); +PROCEDURE TXmlParser.AnalyzeEntityDecl (Start : TCharType; VAR Final : TCharType); (* Parse ' character XmlSpec 4.2: @@ -2140,7 +1932,7 @@ VAR Phase : TPhase; IsParamEntity : BOOLEAN; - F : PAnsiChar; + F : TCharType; ExternalID : TExternalID; EntityDef : TEntityDef; EntityDef2 : TEntityDef; @@ -2215,7 +2007,7 @@ END; -PROCEDURE TXmlParser.AnalyzeNotationDecl (Start : PAnsiChar; VAR Final : PAnsiChar); +PROCEDURE TXmlParser.AnalyzeNotationDecl (Start : TCharType; VAR Final : TCharType); // Parse ' character // XmlSpec 4.7: NotationDecl ::= '' @@ -2224,7 +2016,7 @@ VAR ExternalID : TExternalID; Phase : TPhase; - F : PAnsiChar; + F : TCharType; NotationDef : TNotationDef; DER : TDtdElementRec; BEGIN @@ -2267,13 +2059,13 @@ END; -PROCEDURE TXmlParser.PushPE (VAR Start : PAnsiChar); +PROCEDURE TXmlParser.PushPE (VAR Start : TCharType); (* If there is a parameter entity reference found in the data stream, the current position will be pushed to the entity stack. Start: IN Pointer to the '%' character starting the PE reference OUT Pointer to first character of PE replacement text *) VAR - P : PAnsiChar; + P : TCharType; EntityDef : TEntityDef; BEGIN P := StrScan (Start, ';'); @@ -2281,7 +2073,7 @@ EntityDef := TEntityDef (ParEntities.Node (StrSFPas (Start+1, P-1))); IF EntityDef <> NIL THEN BEGIN EntityStack.Push (P+1); - Start := PAnsiChar (EntityDef.Value); + Start := TCharType (EntityDef.Value); END ELSE Start := P+1; @@ -2289,24 +2081,24 @@ END; -PROCEDURE TXmlParser.ReplaceCharacterEntities (VAR Str : AnsiString); +PROCEDURE TXmlParser.ReplaceCharacterEntities (VAR Str : TStringType); // Replaces all Character References in the String VAR Start : INTEGER; - PAmp : PAnsiChar; - PSemi : PAnsiChar; + PAmp : TCharType; + PSemi : TCharType; PosAmp : INTEGER; Len : INTEGER; // Length of complete Character Reference - Repl : AnsiString; // Replacement Text + Repl : TStringType; // Replacement Text BEGIN IF Str = '' THEN EXIT; Start := 1; REPEAT - PAmp := StrPos (PAnsiChar (Str) + Start-1, '&#'); + PAmp := StrPos (TCharType (Str) + Start-1, '&#'); IF PAmp = NIL THEN BREAK; PSemi := StrScan (PAmp + 3, ';'); IF PSemi = NIL THEN BREAK; - PosAmp := PAmp - PAnsiChar (Str) + 1; + PosAmp := PAmp - TCharType (Str) + 1; Len := PSemi - PAmp + 1; IF (PAmp + 2)^ = 'x' THEN Repl := TranslateCharacter (StrToIntDef ('$' + Copy (string (Str), PosAmp + 3, Len - 4), 32)) @@ -2318,26 +2110,26 @@ END; -PROCEDURE TXmlParser.ReplaceParameterEntities (VAR Str : AnsiString); +PROCEDURE TXmlParser.ReplaceParameterEntities (VAR Str : TStringType); // Recursively replaces all Parameter Entity References in the String - PROCEDURE ReplaceEntities (VAR Str : AnsiString); + PROCEDURE ReplaceEntities (VAR Str : TStringType); VAR Start : INTEGER; - PAmp : PAnsiChar; - PSemi : PAnsiChar; + PAmp : TCharType; + PSemi : TCharType; PosAmp : INTEGER; Len : INTEGER; Entity : TEntityDef; - Repl : AnsiString; // Replacement + Repl : TStringType; // Replacement BEGIN IF Str = '' THEN EXIT; Start := 1; REPEAT - PAmp := StrPos (PAnsiChar (Str)+Start-1, '%'); + PAmp := StrPos (TCharType (Str)+Start-1, '%'); IF PAmp = NIL THEN BREAK; PSemi := StrScan (PAmp+2, ';'); IF PSemi = NIL THEN BREAK; - PosAmp := PAmp - PAnsiChar (Str) + 1; + PosAmp := PAmp - TCharType (Str) + 1; Len := PSemi-PAmp+1; Entity := TEntityDef (ParEntities.Node (Copy (Str, PosAmp+1, Len-2))); IF Entity <> NIL THEN BEGIN @@ -2356,7 +2148,7 @@ END; -FUNCTION TXmlParser.LoadExternalEntity (SystemId, PublicId, Notation : AnsiString) : TXmlParser; +FUNCTION TXmlParser.LoadExternalEntity (SystemId, PublicId, Notation : TStringType) : TXmlParser; // This will be called whenever there is a Parsed External Entity or // the DTD External Subset has to be loaded. // It must create a TXmlParser instance and load the desired Entity. @@ -2381,7 +2173,7 @@ END; -FUNCTION TXmlParser.TranslateEncoding (CONST Source : AnsiString) : AnsiString; +FUNCTION TXmlParser.TranslateEncoding (CONST Source : TStringType) : TStringType; // The member variable "CurEncoding" always holds the name of the current // encoding, e.g. 'UTF-8' or 'ISO-8859-1' (always uppercase). // This virtual method "TranslateEncoding" is responsible for translating @@ -2393,15 +2185,11 @@ // Override this function when you want your application to understand other // source encodings or create other target encodings. BEGIN - IF CurEncoding = 'UTF-8' - THEN Result := LibXmlParser.Utf8ToAnsi (Source) - ELSE Result := Source; + Result := Source;//Utf8ToAnsi (Source) END; - - FUNCTION TXmlParser.TranslateCharacter (CONST UnicodeValue : INTEGER; - CONST UnknownChar : AnsiString = CUnknownChar) : AnsiString; + CONST UnknownChar : TStringType = CUnknownChar) : TStringType; // Corresponding to TranslateEncoding, the task of TranslateCharacter is // to translate a given Character value to the representation in the target charset. // This instance of TranslateCharacter assumes that the application expects @@ -2410,16 +2198,10 @@ var I : integer; begin - if (UnicodeValue <= 127) then begin - Result := AnsiChar (UnicodeValue); + if (UnicodeValue <= 255) then begin + Result := TCharType(UnicodeValue); exit; - end - else - for I := 128 to 255 do - if UnicodeValue = WIN1252_UNICODE [I] then begin - Result := AnsiChar (I); - exit; - end; + end; Result := CUnknownChar; END; @@ -2435,7 +2217,7 @@ procedure TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); END; -FUNCTION TXmlParser.GetDocBuffer: PAnsiChar; +FUNCTION TXmlParser.GetDocBuffer: TCharType; // Returns FBuffer or a pointer to a NUL char if Buffer is empty BEGIN IF FBuffer = NIL @@ -2482,7 +2264,7 @@ procedure TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); =============================================================================================== *) -CONSTRUCTOR TNvpNode.Create (TheName, TheValue : AnsiString); +CONSTRUCTOR TNvpNode.Create (TheName, TheValue : TStringType); BEGIN INHERITED Create; Name := TheName; @@ -2512,7 +2294,7 @@ procedure TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); -FUNCTION TNvpList.Node (Name : AnsiString) : TNvpNode; +FUNCTION TNvpList.Node (Name : TStringType) : TNvpNode; // Binary search for Node VAR L, H : INTEGER; // Low, High Limit @@ -2549,7 +2331,7 @@ procedure TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); END; -FUNCTION TNvpList.Value (Name : AnsiString) : AnsiString; +FUNCTION TNvpList.Value (Name : TStringType) : TStringType; VAR Nvp : TNvpNode; BEGIN @@ -2560,7 +2342,7 @@ procedure TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); END; -FUNCTION TNvpList.Value (Index : INTEGER) : AnsiString; +FUNCTION TNvpList.Value (Index : INTEGER) : TStringType; BEGIN IF (Index < 0) OR (Index >= Count) THEN Result := '' @@ -2568,7 +2350,7 @@ procedure TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); END; -FUNCTION TNvpList.Name (Index : INTEGER) : AnsiString; +FUNCTION TNvpList.Name (Index : INTEGER) : TStringType; BEGIN IF (Index < 0) OR (Index >= Count) THEN Result := '' @@ -2585,7 +2367,7 @@ procedure TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); =============================================================================================== *) -PROCEDURE TAttrList.Analyze (Start : PAnsiChar; VAR Final : PAnsiChar); +PROCEDURE TAttrList.Analyze (Start : TCharType; VAR Final : TCharType); // Analyze the Buffer for Attribute=Name pairs. // Terminates when there is a character which is not IN CNameStart // (e.g. '?>' or '>' or '/>') @@ -2593,9 +2375,9 @@ procedure TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); TPhase = (phName, phEq, phValue); VAR Phase : TPhase; - F : PAnsiChar; - Name : AnsiString; - Value : AnsiString; + F : TCharType; + Name : TStringType; + Value : TStringType; Attr : TAttr; BEGIN Clear; @@ -2641,7 +2423,7 @@ procedure TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); =============================================================================================== *) -FUNCTION TElemList.Node (Name : AnsiString) : TElemDef; +FUNCTION TElemList.Node (Name : TStringType) : TElemDef; // Binary search for the Node with the given Name VAR L, H : INTEGER; // Low, High Limit @@ -2695,10 +2477,10 @@ procedure TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); Scanner : TCustomXmlScanner; CONSTRUCTOR Create (TheScanner : TCustomXmlScanner); FUNCTION LoadExternalEntity (SystemId, PublicId, - Notation : AnsiString) : TXmlParser; OVERRIDE; - FUNCTION TranslateEncoding (CONST Source : AnsiString) : AnsiString; OVERRIDE; + Notation : TStringType) : TXmlParser; OVERRIDE; + FUNCTION TranslateEncoding (CONST Source : TStringType) : TStringType; OVERRIDE; FUNCTION TranslateCharacter (CONST UnicodeValue : INTEGER; - CONST UnknownChar : AnsiString = CUnknownChar) : AnsiString; OVERRIDE; + CONST UnknownChar : TStringType = CUnknownChar) : TStringType; OVERRIDE; PROCEDURE DtdElementFound (DtdElementRec : TDtdElementRec); OVERRIDE; END; @@ -2709,7 +2491,7 @@ procedure TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); END; -FUNCTION TScannerXmlParser.LoadExternalEntity (SystemId, PublicId, Notation : AnsiString) : TXmlParser; +FUNCTION TScannerXmlParser.LoadExternalEntity (SystemId, PublicId, Notation : TStringType) : TXmlParser; BEGIN IF Assigned (Scanner.FOnLoadExternal) THEN Scanner.FOnLoadExternal (Scanner, string (SystemId), string (PublicId), string (Notation), Result) @@ -2717,20 +2499,20 @@ procedure TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); END; -FUNCTION TScannerXmlParser.TranslateEncoding (CONST Source : AnsiString) : AnsiString; +FUNCTION TScannerXmlParser.TranslateEncoding (CONST Source : TStringType) : TStringType; BEGIN IF Assigned (Scanner.FOnTranslateEncoding) - THEN Result := AnsiString (Scanner.FOnTranslateEncoding (Scanner, string (CurEncoding), string (Source))) - ELSE Result := AnsiString (INHERITED TranslateEncoding (Source)); + THEN Result := TStringType (Scanner.FOnTranslateEncoding (Scanner, string (CurEncoding), string (Source))) + ELSE Result := TStringType (INHERITED TranslateEncoding (Source)); END; FUNCTION TScannerXmlParser.TranslateCharacter (CONST UnicodeValue : INTEGER; - CONST UnknownChar : AnsiString = CUnknownChar) : AnsiString; + CONST UnknownChar : TStringType = CUnknownChar) : TStringType; BEGIN IF Assigned (Scanner.FOnTranslateCharacter) - THEN Result := AnsiString (Scanner.FOnTranslateCharacter (Scanner, UnicodeValue)) - ELSE Result := AnsiString (INHERITED TranslateCharacter (UnicodeValue, UnknownChar)); + THEN Result := TStringType (Scanner.FOnTranslateCharacter (Scanner, UnicodeValue)) + ELSE Result := TStringType (INHERITED TranslateCharacter (UnicodeValue, UnknownChar)); END; @@ -2776,14 +2558,14 @@ procedure TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); END; -PROCEDURE TCustomXmlScanner.LoadFromBuffer (Buffer : PAnsiChar); +PROCEDURE TCustomXmlScanner.LoadFromBuffer (Buffer : TCharType); // Load XML Document from buffer BEGIN FXmlParser.LoadFromBuffer (Buffer); END; -PROCEDURE TCustomXmlScanner.SetBuffer (Buffer : PAnsiChar); +PROCEDURE TCustomXmlScanner.SetBuffer (Buffer : TCharType); // Refer to Buffer BEGIN FXmlParser.SetBuffer (Buffer); @@ -2903,7 +2685,7 @@ procedure TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); END; -PROCEDURE TCustomXmlScanner.WhenDtdError (ErrorPos : PAnsiChar); +PROCEDURE TCustomXmlScanner.WhenDtdError (ErrorPos : TCharType); // Is called when the parser has found an Error in the DTD BEGIN IF Assigned (FOnDtdError) THEN FOnDtdError (Self, ErrorPos); diff --git a/Source/System/RegexHelper.pas b/Source/System/RegexHelper.pas index d4efcb0..5b954b7 100644 --- a/Source/System/RegexHelper.pas +++ b/Source/System/RegexHelper.pas @@ -1,7 +1,7 @@ unit RegexHelper; interface - uses Global, SysUtils, StrUtils, PerlRegEx; + uses Global, SysUtils, StrUtils, RegularExpressionsCore; type T2Int = record i1, i2: integer; @@ -27,14 +27,16 @@ implementation function GetStringPart(text, expression: string; group: integer; def: string): string; var Regex: TPerlRegEx; begin - Regex := TPerlRegEx.Create(nil); - Regex.RegEx := expression; + Regex := TPerlRegEx.Create; + Regex.RegEx := Utf8String(expression); Regex.Options := [preSingleLine, preCaseless]; - Regex.Subject := text; + Regex.Subject := Utf8String(text); - if Regex.Match and (Regex.SubExpressionCount >= group) then - Result := Regex.SubExpressions[group] + if Regex.Match and (Regex.GroupCount >= group) then + Result := String(Regex.Groups[group]) else Result := def; + + Regex.Free; end; function GetBoolPart(text, expression: string; group: integer; def: boolean): boolean; begin diff --git a/Source/System/Windows7.pas b/Source/System/Windows7.pas new file mode 100644 index 0000000..a0da3f6 --- /dev/null +++ b/Source/System/Windows7.pas @@ -0,0 +1,155 @@ +/////////////////////////////////////////////////////////////////////////////// +// LameXP - Audio Encoder Front-End +// Copyright (C) 2004-2010 LoRd_MuldeR +// +// This program is free software; you can redistribute it and/or modify +// it under the terms of the GNU General Public License as published by +// the Free Software Foundation; either version 2 of the License, or +// (at your option) any later version. +// +// This program is distributed in the hope that it will be useful, +// but WITHOUT ANY WARRANTY; without even the implied warranty of +// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +// GNU General Public License for more details. +// +// You should have received a copy of the GNU General Public License along +// with this program; if not, write to the Free Software Foundation, Inc., +// 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. +// +// http://www.gnu.org/licenses/gpl-2.0.txt +/////////////////////////////////////////////////////////////////////////////// + +unit Windows7; + +////////////////////////////////////////////////////////////////////////////// +interface +////////////////////////////////////////////////////////////////////////////// + +uses + Forms, Types, Windows, SysUtils, ComObj, Controls, Graphics; + +type + TTaskBarProgressState = (tbpsNone, tbpsIndeterminate, tbpsNormal, tbpsError, tbpsPaused); + +function InitializeTaskbarAPI: Boolean; +function SetTaskbarProgressState(const AState: TTaskBarProgressState): Boolean; +function SetTaskbarProgressValue(const ACurrent:UInt64; const AMax: UInt64): Boolean; + +////////////////////////////////////////////////////////////////////////////// +implementation +////////////////////////////////////////////////////////////////////////////// + +const + TASKBAR_CID: TGUID = '{56FDF344-FD6D-11d0-958A-006097C9A090}'; + +const + TBPF_NOPROGRESS = 0; + TBPF_INDETERMINATE = 1; + TBPF_NORMAL = 2; + TBPF_ERROR = 4; + TBPF_PAUSED = 8; + +type + ITaskBarList3 = interface(IUnknown) + ['{EA1AFB91-9E28-4B86-90E9-9E9F8A5EEFAF}'] + function HrInit(): HRESULT; stdcall; + function AddTab(hwnd: THandle): HRESULT; stdcall; + function DeleteTab(hwnd: THandle): HRESULT; stdcall; + function ActivateTab(hwnd: THandle): HRESULT; stdcall; + function SetActiveAlt(hwnd: THandle): HRESULT; stdcall; + function MarkFullscreenWindow(hwnd: THandle; fFullscreen: Boolean): HRESULT; stdcall; + function SetProgressValue(hwnd: THandle; ullCompleted: UInt64; ullTotal: UInt64): HRESULT; stdcall; + function SetProgressState(hwnd: THandle; tbpFlags: Cardinal): HRESULT; stdcall; + function RegisterTab(hwnd: THandle; hwndMDI: THandle): HRESULT; stdcall; + function UnregisterTab(hwndTab: THandle): HRESULT; stdcall; + function SetTabOrder(hwndTab: THandle; hwndInsertBefore: THandle): HRESULT; stdcall; + function SetTabActive(hwndTab: THandle; hwndMDI: THandle; tbatFlags: Cardinal): HRESULT; stdcall; + function ThumbBarAddButtons(hwnd: THandle; cButtons: Cardinal; pButtons: Pointer): HRESULT; stdcall; + function ThumbBarUpdateButtons(hwnd: THandle; cButtons: Cardinal; pButtons: Pointer): HRESULT; stdcall; + function ThumbBarSetImageList(hwnd: THandle; himl: THandle): HRESULT; stdcall; + function SetOverlayIcon(hwnd: THandle; hIcon: THandle; pszDescription: PChar): HRESULT; stdcall; + function SetThumbnailTooltip(hwnd: THandle; pszDescription: PChar): HRESULT; stdcall; + function SetThumbnailClip(hwnd: THandle; var prcClip: TRect): HRESULT; stdcall; + end; + +////////////////////////////////////////////////////////////////////////////// + +var + GlobalTaskBarInterface: ITaskBarList3; + +function InitializeTaskbarAPI: Boolean; +var + Unknown: IInterface; + Temp: ITaskBarList3; +begin + if Assigned(GlobalTaskBarInterface) then + begin + Result := True; + Exit; + end; + + try + Unknown := CreateComObject(TASKBAR_CID); + if Assigned(Unknown) then + begin + Temp := Unknown as ITaskBarList3; + if Temp.HrInit() = S_OK then + begin + GlobalTaskBarInterface := Temp; + end; + end; + except + GlobalTaskBarInterface := nil; + end; + + Result := Assigned(GlobalTaskBarInterface); +end; + +function CheckAPI:Boolean; +begin + Result := Assigned(GlobalTaskBarInterface); +end; + +////////////////////////////////////////////////////////////////////////////// + +function SetTaskbarProgressState(const AState: TTaskBarProgressState): Boolean; +var + Flag: Cardinal; +begin + Result := False; + + if CheckAPI then + begin + case AState of + tbpsIndeterminate: Flag := TBPF_INDETERMINATE; + tbpsNormal: Flag := TBPF_NORMAL; + tbpsError: Flag := TBPF_ERROR; + tbpsPaused: Flag := TBPF_PAUSED; + else + Flag := TBPF_NOPROGRESS; + end; + Result := GlobalTaskBarInterface.SetProgressState(Application.Handle, Flag) = S_OK; + end; +end; + +function SetTaskbarProgressValue(const ACurrent:UInt64; const AMax: UInt64): Boolean; +begin + Result := False; + + if CheckAPI then + begin + Result := GlobalTaskBarInterface.SetProgressValue(Application.Handle, ACurrent, AMax) = S_OK; + end; +end; + +////////////////////////////////////////////////////////////////////////////// + +initialization + GlobalTaskBarInterface := nil; + +finalization + GlobalTaskBarInterface := nil; + +////////////////////////////////////////////////////////////////////////////// + +end. \ No newline at end of file diff --git a/Source/ZLibEx.inc b/Source/System/ZLibEx.inc similarity index 100% rename from Source/ZLibEx.inc rename to Source/System/ZLibEx.inc diff --git a/Source/System/pngextra.pas b/Source/System/pngextra.pas new file mode 100644 index 0000000..86b3112 --- /dev/null +++ b/Source/System/pngextra.pas @@ -0,0 +1,353 @@ +unit pngextra; + +interface + +uses + Windows, Graphics, Messages, SysUtils, Classes, Controls, pngimage, Buttons, + ExtCtrls; + +type + TPNGButtonStyle = (pbsDefault, pbsFlat, pbsNoFrame); + TPNGButtonLayout = (pbsImageAbove, pbsImageBellow, pbsImageLeft, + pbsImageRight); + TPNGButtonState = (pbsNormal, pbsDown, pbsDisabled); + + TPNGButton = class(TGraphicControl) + private + {Holds the property values} + fButtonStyle: TPNGButtonStyle; + fMouseOverControl: Boolean; + FCaption: String; + FButtonLayout: TPNGButtonLayout; + FButtonState: TPNGButtonState; + FImageDown: TPNGObject; + fImageNormal: TPNGObject; + fImageDisabled: TPNGObject; + fImageOver: TPNGObject; + fOnMouseEnter, fOnMouseExit: TNotifyEvent; + {Procedures for setting the property values} + procedure SetButtonStyle(const Value: TPNGButtonStyle); + procedure SetCaption(const Value: String); + procedure SetButtonLayout(const Value: TPNGButtonLayout); + procedure SetButtonState(const Value: TPNGButtonState); + procedure SetImageNormal(const Value: TPNGObject); + procedure SetImageDown(const Value: TPNGObject); + procedure SetImageOver(const Value: TPNGObject); + published + {Published properties} + property Font; + property Visible; + property ButtonLayout: TPNGButtonLayout read FButtonLayout write SetButtonLayout; + property Caption: String read FCaption write SetCaption; + property ImageNormal: TPNGObject read fImageNormal write SetImageNormal; + property ImageDown: TPNGObject read FImageDown write SetImageDown; + property ImageOver: TPNGObject read FImageOver write SetImageOver; + property ButtonStyle: TPNGButtonStyle read fButtonStyle + write SetButtonStyle; + property Enabled; + property ParentShowHint; + property ShowHint; + {Default events} + property OnMouseDown; + property OnClick; + property OnMouseUp; + property OnMouseMove; + property OnDblClick; + property OnMouseEnter: TNotifyEvent read fOnMouseEnter write fOnMouseEnter; + property OnMouseExit: TNotifyEvent read fOnMouseExit write fOnMouseExit; + public + {Public properties} + property ButtonState: TPNGButtonState read FButtonState write SetButtonState; + protected + {Being painted} + procedure Paint; override; + {Clicked} + procedure Click; override; + {Mouse pressed} + procedure MouseDown(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); override; + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); override; + procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; + {Mouse entering or leaving} + procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER; + procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE; + {Being enabled or disabled} + procedure CMEnabledChanged(var Message: TMessage); + message CM_ENABLEDCHANGED; + public + {Returns if the mouse is over the control} + property IsMouseOver: Boolean read fMouseOverControl; + {Constructor and destructor} + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + end; + +procedure Register; +procedure MakeImageHalfTransparent(Source, Dest: TPNGObject); + +implementation + +procedure Register; +begin + RegisterComponents('Samples', [TPNGButton]); +end; + +procedure MakeImageHalfTransparent(Source, Dest: TPNGObject); +var + i, j: Integer; +begin + Dest.Assign(Source); + Dest.CreateAlpha; + if (Dest.Header.ColorType <> COLOR_PALETTE) then + for j := 0 to Source.Height - 1 do + for i := 0 to Source.Width - 1 do + Dest.AlphaScanline[j]^[i] := Dest.AlphaScanline[j]^[i] div 3; +end; + +{TPNGButton implementation} + +{Being created} +constructor TPNGButton.Create(AOwner: TComponent); +begin + {Calls ancestor} + inherited Create(AOwner); + {Creates the TPNGObjects} + fImageNormal := TPNGObject.Create; + fImageDown := TPNGObject.Create; + fImageDisabled := TPNGObject.Create; + fImageOver := TPNGObject.Create; + {Initial properties} + ControlStyle := ControlStyle + [csCaptureMouse]; + SetBounds(Left, Top, 23, 23); + fMouseOverControl := False; + fButtonLayout := pbsImageAbove; + fButtonState := pbsNormal +end; + +destructor TPNGButton.Destroy; +begin + {Frees the TPNGObject} + fImageNormal.Free; + fImageDown.Free; + fImageDisabled.Free; + fImageOver.Free; + + {Calls ancestor} + inherited Destroy; +end; + +{Being enabled or disabled} +procedure TPNGButton.CMEnabledChanged(var Message: TMessage); +begin + if not Enabled then MakeImageHalfTransparent(fImageNormal, fImageDisabled); + if Enabled then ButtonState := pbsNormal else ButtonState := pbsDisabled +end; + +{Returns the largest number} +function Max(A, B: Integer): Integer; +begin + if A > B then Result := A else Result := B +end; + +{Button being painted} +procedure TPNGButton.Paint; +const + Slide: Array[false..true] of Integer = (0, 2); +var + Area: TRect; + TextSize, ImageSize: TSize; + TextPos, ImagePos: TPoint; + Image: TPNGObject; + Pushed: Boolean; +begin + {Prepares the canvas} + Canvas.Font.Assign(Font); + + {Determines if the button is pushed} + Pushed := (ButtonState = pbsDown) and IsMouseOver; + + {Determines the image to use} + if (Pushed) and not fImageDown.Empty then + Image := fImageDown + else if IsMouseOver and not fImageOver.Empty and Enabled then + Image := fImageOver + else if (ButtonState = pbsDisabled) and not fImageDisabled.Empty then + Image := fImageDisabled + else + Image := fImageNormal; + + {Get the elements size} + ImageSize.cx := Image.Width; + ImageSize.cy := Image.Height; + Area := ClientRect; + if Caption <> '' then + begin + TextSize := Canvas.TextExtent(Caption); + ImageSize.cy := ImageSize.Cy + 4; + end else FillChar(TextSize, SizeOf(TextSize), #0); + + {Set the elements position} + ImagePos.X := (Width - ImageSize.cx) div 2 + Slide[Pushed]; + TextPos.X := (Width - TextSize.cx) div 2 + Slide[Pushed]; + TextPos.Y := (Height - TextSize.cy) div 2; + ImagePos.Y := (Height - ImageSize.cy) div 2; + case ButtonLayout of + pbsImageAbove: begin + ImagePos.Y := (Height - ImageSize.cy - TextSize.cy) div 2; + TextPos.Y := ImagePos.Y + ImageSize.cy; + end; + pbsImageBellow: begin + TextPos.Y := (Height - ImageSize.cy - TextSize.cy) div 2; + ImagePos.Y := TextPos.Y + TextSize.cy; + end; + pbsImageLeft: begin + ImagePos.X := (Width - ImageSize.cx - TextSize.cx) div 2; + TextPos.X := ImagePos.X + ImageSize.cx + 5; + end; + pbsImageRight: begin + TextPos.X := (Width - ImageSize.cx - TextSize.cx) div 2;; + ImagePos.X := TextPos.X + TextSize.cx + 5; + end + end; + ImagePos.Y := ImagePos.Y + Slide[Pushed]; + TextPos.Y := TextPos.Y + Slide[Pushed]; + + {Draws the border} + if ButtonStyle = pbsFlat then + begin + if ButtonState <> pbsDisabled then + if (Pushed) then + Frame3D(Canvas, Area, clBtnShadow, clBtnHighlight, 1) + else if IsMouseOver or (ButtonState = pbsDown) then + Frame3D(Canvas, Area, clBtnHighlight, clBtnShadow, 1) + end + else if ButtonStyle = pbsDefault then + DrawButtonFace(Canvas, Area, 1, bsNew, TRUE, Pushed, FALSE); + + {Draws the elements} + Canvas.Brush.Style := bsClear; + Canvas.Draw(ImagePos.X, ImagePos.Y, Image); + if ButtonState = pbsDisabled then Canvas.Font.Color := clGrayText; + Canvas.TextRect(Area, TextPos.X, TextPos.Y, Caption) +end; + +{Changing the button Layout property} +procedure TPNGButton.SetButtonLayout(const Value: TPNGButtonLayout); +begin + FButtonLayout := Value; + Repaint +end; + +{Changing the button state property} +procedure TPNGButton.SetButtonState(const Value: TPNGButtonState); +begin + FButtonState := Value; + Repaint +end; + +{Changing the button style property} +procedure TPNGButton.SetButtonStyle(const Value: TPNGButtonStyle); +begin + fButtonStyle := Value; + Repaint +end; + +{Changing the caption property} +procedure TPNGButton.SetCaption(const Value: String); +begin + FCaption := Value; + Repaint +end; + +{Changing the image property} +procedure TPNGButton.SetImageNormal(const Value: TPNGObject); +begin + fImageNormal.Assign(Value); + MakeImageHalfTransparent(fImageNormal, fImageDisabled); + Repaint +end; + +{Setting the down image} +procedure TPNGButton.SetImageDown(const Value: TPNGObject); +begin + FImageDown.Assign(Value); + Repaint +end; + +{Setting the over image} +procedure TPNGButton.SetImageOver(const Value: TPNGObject); +begin + fImageOver.Assign(Value); + Repaint +end; + +{Mouse pressed} +procedure TPNGButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, + Y: Integer); +begin + {Changes the state and repaints} + if (ButtonState = pbsNormal) and (Button = mbLeft) then + ButtonState := pbsDown; + {Calls ancestor} + inherited +end; + +{Being clicked} +procedure TPNGButton.Click; +begin + if ButtonState = pbsDown then ButtonState := pbsNormal; + inherited Click; +end; + +{Mouse released} +procedure TPNGButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, + Y: Integer); +begin + {Changes the state and repaints} + if ButtonState = pbsDown then ButtonState := pbsNormal; + {Calls ancestor} + inherited +end; + +{Mouse moving over the control} +procedure TPNGButton.MouseMove(Shift: TShiftState; X, Y: Integer); +begin + {In case cursor is over the button} + if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) and + (fMouseOverControl = False) and (ButtonState <> pbsDown) then + begin + fMouseOverControl := True; + Repaint; + end; + + {Calls ancestor} + inherited; + +end; + +{Mouse is now over the control} +procedure TPNGButton.CMMouseEnter(var Message: TMessage); +begin + if Enabled then + begin + if Assigned(fOnMouseEnter) then fOnMouseEnter(Self); + fMouseOverControl := True; + Repaint + end +end; + +{Mouse has left the control} +procedure TPNGButton.CMMouseLeave(var Message: TMessage); +begin + if Enabled then + begin + if Assigned(fOnMouseExit) then FOnMouseExit(Self); + fMouseOverControl := False; + Repaint + end +end; + + + +end. diff --git a/Source/System/pngimage.pas b/Source/System/pngimage.pas index b7e3f88..d873ca0 100644 --- a/Source/System/pngimage.pas +++ b/Source/System/pngimage.pas @@ -1,12 +1,193 @@ -{*******************************************************} -{ } -{ CodeGear Delphi Visual Component Library } -{ } -{ Copyright (c) 1995-2008 CodeGear } -{ } -{ Original version written by Gustavo Daud } -{ } -{*******************************************************} +{Portable Network Graphics Delphi 1.564 (31 July 2006) } + +{This is a full, open sourced implementation of png in Delphi } +{It has native support for most of png features including the } +{partial transparency, gamma and more. } +{For the latest version, please be sure to check my website } +{http://pngdelphi.sourceforge.net } +{Gustavo Huffenbacher Daud (gustavo.daud@terra.com.br) } + + +{ + Version 1.564 + 2006-07-25 BUG 1 - There was one GDI Palette object leak + when assigning from other PNG (fixed) + BUG 2 - Loosing color information when assigning png + to bmp on lower screen depth system + BUG 3 - There was a bug in TStream.GetSize + (fixed thanks to Vladimir Panteleev) + IMPROVE 1 - When assigning png to bmp now alpha information + is drawn (simulated into a white background) + + Version 1.563 + 2006-07-25 BUG 1 - There was a memory bug in the main component + destructor (fixed thanks to Steven L Brenner) + BUG 2 - The packages name contained spaces which was + causing some strange bugs in Delphi + (fixed thanks to Martijn Saly) + BUG 3 - Lots of fixes when handling palettes + (bugs implemented in the last version) + Fixed thanks to Gabriel Corneanu!!! + BUG 4 - CreateAlpha was raising an error because it did + not resized the palette chunk it created; + Fixed thanks to Miha Sokolov + IMPROVE 1 - Renamed the pngzlib.pas unit to zlibpas.pas + as a tentative to all libraries use the same + shared zlib implementation and to avoid including + two or three times the same P-Code. + (Gabriel Corneanu idea) + + + + Version 1.561 + 2006-05-17 BUG 1 - There was a bug in the method that draws semi + transparent images (a memory leak). fixed. + + Version 1.56 + 2006-05-09 - IMPROVE 1 - Delphi standard TCanvas support is now implemented + IMPROVE 2 - The PNG files may now be resized and created from + scratch using CreateBlank, Resize, Width and Height + BUG 1 - Fixed some bugs on handling tRNS transparencies + BUG 2 - Fixed bugs related to palette handling + + Version 1.535 + 2006-04-21 - IMPROVE 1 - Now the library uses the latest ZLIB release (1.2.3) + (thanks to: Roberto Della Pasqua + http://www.dellapasqua.com/delphizlib/) + + Version 1.53 + 2006-04-14 - + BUG 1 - Remove transparency was not working for + RGB Alpha and Grayscale alpha. fixed + BUG 2 - There was a bug were compressed text chunks no keyword + name could not be read + IMPROVE 1 - Add classes and methods to work with the pHYs chunk + (including TPNGObject.DrawUsingPixelInformation) + IMPROVE 3 - Included a property Version to return the library + version + IMPROVE 4 - New polish translation (thanks to Piotr Domanski) + IMPROVE 5 - Now packages for delphi 5, 6, 7, 2005 and 2006 + + Also Martijn Saly (thany) made some improvements in the library: + IMPROVE 1 - SetPixel now works with grayscale + IMPROVE 2 - Palette property now can be written using a + windows handle + Thanks !! + + Version 1.5 + 2005-06-29 - Fixed a lot of bugs using tips from mails that I´ve + being receiving for some time + BUG 1 - Loosing palette when assigning to TBitmap. fixed + BUG 2 - SetPixels and GetPixels worked only with + parameters in range 0..255. fixed + BUG 3 - Force type address off using directive + BUG 4 - TChunkzTXt contained an error + BUG 5 - MaxIdatSize was not working correctly (fixed thanks + to Gabriel Corneanu + BUG 6 - Corrected german translation (thanks to Mael Horz) + And the following improvements: + IMPROVE 1 - Create ImageHandleValue properties as public in + TChunkIHDR to get access to this handle + IMPROVE 2 - Using SetStretchBltMode to improve stretch quality + IMPROVE 3 - Scale is now working for alpha transparent images + IMPROVE 4 - GammaTable propery is now public to support an + article in the help file + + Version 1.4361 + 2003-03-04 - Fixed important bug for simple transparency when using + RGB, Grayscale color modes + + Version 1.436 + 2003-03-04 - * NEW * Property Pixels for direct access to pixels + * IMPROVED * Palette property (TPngObject) (read only) + Slovenian traslation for the component (Miha Petelin) + Help file update (scanline article/png->jpg example) + + Version 1.435 + 2003-11-03 - * NEW * New chunk implementation zTXt (method AddzTXt) + * NEW * New compiler flags to store the extra 8 bits + from 16 bits samples (when saving it is ignored), the + extra data may be acessed using ExtraScanline property + * Fixed * a bug on tIMe chunk + French translation included (Thanks to IBE Software) + Bugs fixed + + Version 1.432 + 2002-08-24 - * NEW * A new method, CreateAlpha will transform the + current image into partial transparency. + Help file updated with a new article on how to handle + partial transparency. + + Version 1.431 + 2002-08-14 - Fixed and tested to work on: + C++ Builder 3 + C++ Builder 5 + Delphi 3 + There was an error when setting TransparentColor, fixed + New method, RemoveTransparency to remove image + BIT TRANSPARENCY + + Version 1.43 + 2002-08-01 - * NEW * Support for Delphi 3 and C++ Builder 3 + Implements mostly some things that were missing, + a few tweaks and fixes. + + Version 1.428 + 2002-07-24 - More minor fixes (thanks to Ian Boyd) + Bit transparency fixes + * NEW * Finally support to bit transparency + (palette / rgb / grayscale -> all) + + Version 1.427 + 2002-07-19 - Lots of bugs and leaks fixed + * NEW * method to easy adding text comments, AddtEXt + * NEW * property for setting bit transparency, + TransparentColor + + Version 1.426 + 2002-07-18 - Clipboard finally fixed and working + Changed UseDelphi trigger to UseDelphi + * NEW * Support for bit transparency bitmaps + when assigning from/to TBitmap objects + Altough it does not support drawing transparent + parts of bit transparency pngs (only partial) + it is closer than ever + + Version 1.425 + 2002-07-01 - Clipboard methods implemented + Lots of bugs fixed + + Version 1.424 + 2002-05-16 - Scanline and AlphaScanline are now working correctly. + New methods for handling the clipboard + + Version 1.423 + 2002-05-16 - * NEW * Partial transparency for 1, 2, 4 and 8 bits is + also supported using the tRNS chunk (for palette and + grayscaling). + New bug fixes (Peter Haas). + + Version 1.422 + 2002-05-14 - Fixed some critical leaks, thanks to Peter Haas tips. + New translation for German (Peter Haas). + + Version 1.421 + 2002-05-06 - Now uses new ZLIB version, 1.1.4 with some security + fixes. + LoadFromResourceID and LoadFromResourceName added and + help file updated for that. + The resources strings are now located in pnglang.pas. + New translation for Brazilian Portuguese. + Bugs fixed. + + IMPORTANT: As always I´m looking for bugs on the library. If + anyone has found one, please send me an email and + I will fix asap. Thanks for all the help and ideas + I'm receiving so far.} + +{My email is : gustavo.daud@terra.com.br} +{Website link : http://pngdelphi.sourceforge.net} +{Gustavo Huffenbacher Daud} unit pngimage; @@ -23,11 +204,11 @@ interface {$DEFINE Store16bits} //Stores the extra 8 bits from 16bits/sample {$RANGECHECKS OFF} {$J+} -{$HPPEMIT '#pragma link "pngimage.obj"'} //Resolve linkage for C++ + uses Windows {$IFDEF UseDelphi}, Classes, Graphics, SysUtils{$ENDIF}, - zlib, pnglang; + zlibpas, pnglang; const LibraryVersion = '1.564'; @@ -125,14 +306,14 @@ EPNGInvalidSpec = class(Exception); pByteArray = ^TByteArray; {Forward} - TPngImage = class; + TPNGObject = class; pPointerArray = ^TPointerArray; TPointerArray = Array[Word] of Pointer; {Contains a list of objects} TPNGPointerList = class private - fOwner: TPngImage; + fOwner: TPNGObject; fCount : Cardinal; fMemory: pPointerArray; function GetItem(Index: Cardinal): Pointer; @@ -149,12 +330,12 @@ TPNGPointerList = class {Set the size of the list} procedure SetSize(const Size: Cardinal); {Returns owner} - property Owner: TPngImage read fOwner; + property Owner: TPNGObject read fOwner; public {Returns number of items} property Count: Cardinal read fCount write SetSize; {Object being either created or destroyed} - constructor Create(AOwner: TPngImage); + constructor Create(AOwner: TPNGObject); destructor Destroy; override; end; @@ -269,7 +450,7 @@ TChunkpHYs = class; TFilters = set of TFilter; {Png implementation object} - TPngImage = class{$IFDEF UseDelphi}(TGraphic){$ENDIF} + TPngObject = class{$IFDEF UseDelphi}(TGraphic){$ENDIF} protected {Inverse gamma table values} InverseGamma: Array[Byte] of Byte; @@ -308,7 +489,6 @@ TPngImage = class{$IFDEF UseDelphi}(TGraphic){$ENDIF} protected {Being created} BeingCreated: Boolean; - function GetSupportsPartialTransparency: Boolean; override; {Returns / set the image palette} function GetPalette: HPALETTE; {$IFDEF UseDelphi}override;{$ENDIF} procedure SetPalette(Value: HPALETTE); {$IFDEF UseDelphi}override;{$ENDIF} @@ -318,8 +498,8 @@ TPngImage = class{$IFDEF UseDelphi}(TGraphic){$ENDIF} function GetHeight: Integer; {$IFDEF UseDelphi}override; {$ENDIF} procedure SetWidth(Value: Integer); {$IFDEF UseDelphi}override; {$ENDIF} procedure SetHeight(Value: Integer); {$IFDEF UseDelphi}override;{$ENDIF} - {Assigns from another TPngImage} - procedure AssignPNG(Source: TPngImage); + {Assigns from another TPNGObject} + procedure AssignPNG(Source: TPNGObject); {Returns if the image is empty} function GetEmpty: Boolean; {$IFDEF UseDelphi}override; {$ENDIF} {Used with property Header} @@ -346,8 +526,8 @@ TPngImage = class{$IFDEF UseDelphi}(TGraphic){$ENDIF} property TransparentColor: TColor read GetTransparentColor write SetTransparentColor; {Add text chunk, TChunkTEXT, TChunkzTXT} - procedure AddtEXt(const Keyword, Text: AnsiString); - procedure AddzTXt(const Keyword, Text: AnsiString); + procedure AddtEXt(const Keyword, Text: String); + procedure AddzTXt(const Keyword, Text: String); {$IFDEF UseDelphi} {Saves to clipboard format (thanks to Antoine Pottern)} procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; @@ -423,10 +603,8 @@ TPngImage = class{$IFDEF UseDelphi}(TGraphic){$ENDIF} property Version: String read GetLibraryVersion; end; - TPNGObject = TPngImage deprecated 'Use TPngImage.'; - {Chunk name object} - TChunkName = Array[0..3] of AnsiChar; + TChunkName = Array[0..3] of Char; {Global chunk object} TChunk = class @@ -435,7 +613,7 @@ TChunk = class fData: Pointer; fDataSize: Cardinal; {Stores owner} - fOwner: TPngImage; + fOwner: TPngObject; {Stores the chunk name} fName: TChunkName; {Returns pointer to the TChunkIHDR} @@ -445,7 +623,7 @@ TChunk = class {Should return chunk class/name} class function GetName: String; virtual; {Returns the chunk name} - function GetChunkName: AnsiString; + function GetChunkName: String; public {Returns index from list} property Index: Integer read GetIndex; @@ -459,12 +637,12 @@ TChunk = class {Assigns from another TChunk} procedure Assign(Source: TChunk); virtual; {Returns owner} - property Owner: TPngImage read fOwner; + property Owner: TPngObject read fOwner; {Being destroyed/created} - constructor Create(Owner: TPngImage); virtual; + constructor Create(Owner: TPngObject); virtual; destructor Destroy; override; {Returns chunk class/name} - property Name: AnsiString read GetChunkName; + property Name: String read GetChunkName; {Loads the chunk from a stream} function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; Size: Integer): Boolean; virtual; @@ -535,7 +713,7 @@ TChunkIHDR = class(TChunk) {Saves the chunk to a stream} function SaveToStream(Stream: TStream): Boolean; override; {Destructor/constructor} - constructor Create(Owner: TPngImage); override; + constructor Create(Owner: TPngObject); override; destructor Destroy; override; {Assigns from another TChunk} procedure Assign(Source: TChunk); override; @@ -575,7 +753,7 @@ TChunkgAMA = class(TChunk) function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; Size: Integer): Boolean; override; {Being created} - constructor Create(Owner: TPngImage); override; + constructor Create(Owner: TPngObject); override; {Assigns from another TChunk} procedure Assign(Source: TChunk); override; end; @@ -681,69 +859,69 @@ TChunkIDAT = class(TChunk) protected {Memory copy methods to decode} procedure CopyNonInterlacedRGB8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyNonInterlacedRGB16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyNonInterlacedPalette148( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyNonInterlacedPalette2( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyNonInterlacedGray2( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyNonInterlacedGrayscale16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyNonInterlacedRGBAlpha8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyNonInterlacedRGBAlpha16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyNonInterlacedGrayscaleAlpha8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyNonInterlacedGrayscaleAlpha16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyInterlacedRGB8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyInterlacedRGB16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyInterlacedPalette148(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyInterlacedPalette2(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyInterlacedGray2(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyInterlacedGrayscale16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyInterlacedRGBAlpha8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyInterlacedRGBAlpha16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyInterlacedGrayscaleAlpha8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); procedure CopyInterlacedGrayscaleAlpha16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); protected {Memory copy methods to encode} - procedure EncodeNonInterlacedRGB8(Src, Dest, Trans: pByte); - procedure EncodeNonInterlacedRGB16(Src, Dest, Trans: pByte); - procedure EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pByte); - procedure EncodeNonInterlacedPalette148(Src, Dest, Trans: pByte); - procedure EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pByte); - procedure EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pByte); - procedure EncodeNonInterlacedGrayscaleAlpha8(Src, Dest, Trans: pByte); - procedure EncodeNonInterlacedGrayscaleAlpha16(Src, Dest, Trans: pByte); - procedure EncodeInterlacedRGB8(const Pass: Byte; Src, Dest, Trans: pByte); - procedure EncodeInterlacedRGB16(const Pass: Byte; Src, Dest, Trans: pByte); + procedure EncodeNonInterlacedRGB8(Src, Dest, Trans: pChar); + procedure EncodeNonInterlacedRGB16(Src, Dest, Trans: pChar); + procedure EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pChar); + procedure EncodeNonInterlacedPalette148(Src, Dest, Trans: pChar); + procedure EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pChar); + procedure EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pChar); + procedure EncodeNonInterlacedGrayscaleAlpha8(Src, Dest, Trans: pChar); + procedure EncodeNonInterlacedGrayscaleAlpha16(Src, Dest, Trans: pChar); + procedure EncodeInterlacedRGB8(const Pass: Byte; Src, Dest, Trans: pChar); + procedure EncodeInterlacedRGB16(const Pass: Byte; Src, Dest, Trans: pChar); procedure EncodeInterlacedPalette148(const Pass: Byte; - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); procedure EncodeInterlacedGrayscale16(const Pass: Byte; - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); procedure EncodeInterlacedRGBAlpha8(const Pass: Byte; - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); procedure EncodeInterlacedRGBAlpha16(const Pass: Byte; - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); procedure EncodeInterlacedGrayscaleAlpha8(const Pass: Byte; - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); procedure EncodeInterlacedGrayscaleAlpha16(const Pass: Byte; - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); public {Loads the chunk from a stream} function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; @@ -778,11 +956,11 @@ TChunktIME = class(TChunk) {Textual data} TChunktEXt = class(TChunk) private - fKeyword, fText: AnsiString; + fKeyword, fText: String; public {Keyword and text} - property Keyword: AnsiString read fKeyword write fKeyword; - property Text: AnsiString read fText write fText; + property Keyword: String read fKeyword write fKeyword; + property Text: String read fText write fText; {Loads the chunk from a stream} function LoadFromStream(Stream: TStream; const ChunkName: TChunkName; Size: Integer): Boolean; override; @@ -1096,7 +1274,7 @@ procedure RegisterCommonChunks; end; {Creates a new chunk of this class} -function CreateClassChunk(Owner: TPngImage; Name: TChunkName): TChunk; +function CreateClassChunk(Owner: TPngObject; Name: TChunkName): TChunk; var i : Integer; NewChunk: TChunkClass; @@ -1108,7 +1286,7 @@ function CreateClassChunk(Owner: TPngImage; Name: TChunkName): TChunk; if Assigned(ChunkClasses) then FOR i := 0 TO ChunkClasses.Count - 1 DO begin - if pChunkClassInfo(ChunkClasses.Item[i])^.ClassName.GetName = string(Name) then + if pChunkClassInfo(ChunkClasses.Item[i])^.ClassName.GetName = Name then begin NewChunk := pChunkClassInfo(ChunkClasses.Item[i])^.ClassName; break; @@ -1226,7 +1404,7 @@ function DecompressZLIB(const Input: Pointer; InputSize: Integer; else if InflateRet < 0 then begin Result := False; - ErrorOutput := string(AnsiString(StreamRec.msg)); + ErrorOutput := StreamRec.msg; InflateEnd(StreamRec); Exit; end {if InflateRet < 0} @@ -1286,7 +1464,7 @@ function CompressZLIB(Input: Pointer; InputSize, CompressionLevel: Integer; else if DeflateRet < 0 then begin Result := False; - ErrorOutput := string(AnsiString(StreamRec.msg)); + ErrorOutput := StreamRec.msg; DeflateEnd(StreamRec); Exit; end {if InflateRet < 0} @@ -1302,7 +1480,7 @@ function CompressZLIB(Input: Pointer; InputSize, CompressionLevel: Integer; {TPngPointerList implementation} {Object being created} -constructor TPngPointerList.Create(AOwner: TPngImage); +constructor TPngPointerList.Create(AOwner: TPNGObject); begin inherited Create; {Let ancestor work} {Holds owner} @@ -1520,7 +1698,7 @@ function TPNGList.ItemFromClass(ChunkClass: TChunkClass): TChunk; const MaxBytes = $f000; var - Buffer: PAnsiChar; + Buffer: PChar; BufSize, N: Cardinal; begin {If count is zero, copy everything from Source} @@ -1736,9 +1914,9 @@ procedure TChunk.Assign(Source: TChunk); end; {Chunk being created} -constructor TChunk.Create(Owner: TPngImage); +constructor TChunk.Create(Owner: TPngObject); var - ChunkName: AnsiString; + ChunkName: String; begin {Ancestor create} inherited Create; @@ -1746,7 +1924,7 @@ constructor TChunk.Create(Owner: TPngImage); {If it's a registered class, set the chunk name based on the class} {name. For instance, if the class name is TChunkgAMA, the GAMA part} {will become the chunk name} - ChunkName := AnsiString(Copy(ClassName, Length('TChunk') + 1, Length(ClassName))); + ChunkName := Copy(ClassName, Length('TChunk') + 1, Length(ClassName)); if Length(ChunkName) = 4 then CopyMemory(@fName[0], @ChunkName[1], 4); {Initialize data holder} @@ -1766,7 +1944,7 @@ destructor TChunk.Destroy; end; {Returns the chunk name 1} -function TChunk.GetChunkName: AnsiString; +function TChunk.GetChunkName: String; begin Result := fName end; @@ -1900,7 +2078,7 @@ function TChunkzTXt.LoadFromStream(Stream: TStream; {Load data from stream and validate} Result := inherited LoadFromStream(Stream, ChunkName, Size); if not Result or (Size < 4) then exit; - fKeyword := PAnsiChar(Data); {Get keyword and compression method bellow} + fKeyword := PChar(Data); {Get keyword and compression method bellow} if Longint(fKeyword) = 0 then CompressionMethod := pByte(Data)^ else @@ -1911,7 +2089,7 @@ function TChunkzTXt.LoadFromStream(Stream: TStream; if CompressionMethod = 0 then begin Output := nil; - if DecompressZLIB(PAnsiChar(Longint(Data) + Length(fKeyword) + 2), + if DecompressZLIB(PChar(Longint(Data) + Length(fKeyword) + 2), Size - Length(fKeyword) - 2, Output, OutputSize, ErrorOutput) then begin SetLength(fText, OutputSize); @@ -1974,7 +2152,7 @@ function TChunktEXt.LoadFromStream(Stream: TStream; Result := inherited LoadFromStream(Stream, ChunkName, Size); if not Result or (Size < 3) then exit; {Get text} - fKeyword := PAnsiChar(Data); + fKeyword := PChar(Data); SetLength(fText, Size - Length(fKeyword) - 1); CopyMemory(@fText[1], Ptr(Longint(Data) + Length(fKeyword) + 1), Length(fText)); @@ -2001,7 +2179,7 @@ function TChunktEXt.SaveToStream(Stream: TStream): Boolean; {TChunkIHDR implementation} {Chunk being created} -constructor TChunkIHDR.Create(Owner: TPngImage); +constructor TChunkIHDR.Create(Owner: TPngObject); begin {Prepare pointers} ImageHandle := 0; @@ -2022,6 +2200,20 @@ destructor TChunkIHDR.Destroy; inherited Destroy; end; +{Copies the palette} +procedure CopyPalette(Source: HPALETTE; Destination: HPALETTE); +var + PaletteSize: Integer; + Entries: Array[Byte] of TPaletteEntry; +begin + PaletteSize := 0; + if GetObject(Source, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit; + if PaletteSize = 0 then Exit; + ResizePalette(Destination, PaletteSize); + GetPaletteEntries(Source, 0, PaletteSize, Entries); + SetPaletteEntries(Destination, 0, PaletteSize, Entries); +end; + {Assigns from another IHDR chunk} procedure TChunkIHDR.Assign(Source: TChunk); begin @@ -2044,7 +2236,7 @@ procedure TChunkIHDR.Assign(Source: TChunk); {Copy palette colors} BitmapInfo.bmiColors := TChunkIHDR(Source).BitmapInfo.bmiColors; {Copy palette also} - Owner.SetPalette(CopyPalette(TChunkIHDR(Source).ImagePalette)); + CopyPalette(TChunkIHDR(Source).ImagePalette, ImagePalette); end else Owner.RaiseError(EPNGError, EPNGCannotAssignChunkText); @@ -2460,7 +2652,7 @@ function TChunkIDAT.IDATZlibRead(var ZLIBStream: TZStreamRec2; var crcfile: Cardinal): Integer; var ProcResult : Integer; - IDATHeader : Array[0..3] of AnsiChar; + IDATHeader : Array[0..3] of char; IDATCRC : Cardinal; begin {Uses internal record pointed by ZLIBStream to gather information} @@ -2565,18 +2757,18 @@ function TChunkIDAT.IDATZlibRead(var ZLIBStream: TZStreamRec2; {Copy interlaced images with 1 byte for R, G, B} procedure TChunkIDAT.CopyInterlacedRGB8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; - Dest := pByte(Longint(Dest) + Col * 3); + Dest := pChar(Longint(Dest) + Col * 3); repeat {Copy this row} - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); {Move to next column} inc(Src, 3); @@ -2587,23 +2779,23 @@ procedure TChunkIDAT.CopyInterlacedRGB8(const Pass: Byte; {Copy interlaced images with 2 bytes for R, G, B} procedure TChunkIDAT.CopyInterlacedRGB16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; - Dest := pByte(Longint(Dest) + Col * 3); + Dest := pChar(Longint(Dest) + Col * 3); repeat {Copy this row} - PByte(Dest)^ := Owner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); - PByte(Dest)^ := Owner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - PByte(Dest)^ := Owner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); + Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := Owner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); {$IFDEF Store16bits} {Copy extra pixel values} - PByte(Extra)^ := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); - PByte(Extra)^ := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); - PByte(Extra)^ := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); {$ENDIF} {Move to next column} @@ -2615,13 +2807,13 @@ procedure TChunkIDAT.CopyInterlacedRGB16(const Pass: Byte; {Copy ímages with palette using bit depths 1, 4 or 8} procedure TChunkIDAT.CopyInterlacedPalette148(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); const BitTable: Array[1..8] of Integer = ($1, $3, 0, $F, 0, 0, 0, $FF); StartBit: Array[1..8] of Integer = (7 , 0 , 0, 4, 0, 0, 0, 0); var CurBit, Col: Integer; - Dest2: pByte; + Dest2: PChar; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; @@ -2630,9 +2822,9 @@ procedure TChunkIDAT.CopyInterlacedPalette148(const Pass: Byte; CurBit := StartBit[Header.BitDepth]; repeat {Adjust pointer to pixel byte bounds} - Dest2 := pByte(Longint(Dest) + (Header.BitDepth * Col) div 8); + Dest2 := pChar(Longint(Dest) + (Header.BitDepth * Col) div 8); {Copy data} - PByte(Dest2)^ := Byte(Dest2^) or + Byte(Dest2^) := Byte(Dest2^) or ( ((Byte(Src^) shr CurBit) and BitTable[Header.BitDepth]) shl (StartBit[Header.BitDepth] - (Col * Header.BitDepth mod 8))); @@ -2649,10 +2841,10 @@ procedure TChunkIDAT.CopyInterlacedPalette148(const Pass: Byte; {Copy ímages with palette using bit depth 2} procedure TChunkIDAT.CopyInterlacedPalette2(const Pass: Byte; Src, Dest, - Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var CurBit, Col: Integer; - Dest2: pByte; + Dest2: PChar; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; @@ -2661,9 +2853,9 @@ procedure TChunkIDAT.CopyInterlacedPalette2(const Pass: Byte; Src, Dest, CurBit := 6; repeat {Adjust pointer to pixel byte bounds} - Dest2 := pByte(Longint(Dest) + Col div 2); + Dest2 := pChar(Longint(Dest) + Col div 2); {Copy data} - PByte(Dest2)^ := Byte(Dest2^) or (((Byte(Src^) shr CurBit) and $3) + Byte(Dest2^) := Byte(Dest2^) or (((Byte(Src^) shr CurBit) and $3) shl (4 - (4 * Col) mod 8)); {Move to next column} inc(Col, ColumnIncrement[Pass]); @@ -2678,10 +2870,10 @@ procedure TChunkIDAT.CopyInterlacedPalette2(const Pass: Byte; Src, Dest, {Copy ímages with grayscale using bit depth 2} procedure TChunkIDAT.CopyInterlacedGray2(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var CurBit, Col: Integer; - Dest2: pByte; + Dest2: PChar; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; @@ -2690,9 +2882,9 @@ procedure TChunkIDAT.CopyInterlacedGray2(const Pass: Byte; CurBit := 6; repeat {Adjust pointer to pixel byte bounds} - Dest2 := pByte(Longint(Dest) + Col div 2); + Dest2 := pChar(Longint(Dest) + Col div 2); {Copy data} - PByte(Dest2)^ := Byte(Dest2^) or ((((Byte(Src^) shr CurBit) shl 2) and $F) + Byte(Dest2^) := Byte(Dest2^) or ((((Byte(Src^) shr CurBit) shl 2) and $F) shl (4 - (Col*4) mod 8)); {Move to next column} inc(Col, ColumnIncrement[Pass]); @@ -2707,18 +2899,18 @@ procedure TChunkIDAT.CopyInterlacedGray2(const Pass: Byte; {Copy ímages with palette using 2 bytes for each pixel} procedure TChunkIDAT.CopyInterlacedGrayscale16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; - Dest := pByte(Longint(Dest) + Col); + Dest := pChar(Longint(Dest) + Col); repeat {Copy this row} Dest^ := Src^; inc(Dest); {$IFDEF Store16bits} - Extra^ := pByte(Longint(Src) + 1)^; inc(Extra); + Extra^ := pChar(Longint(Src) + 1)^; inc(Extra); {$ENDIF} {Move to next column} @@ -2730,20 +2922,20 @@ procedure TChunkIDAT.CopyInterlacedGrayscale16(const Pass: Byte; {Decodes interlaced RGB alpha with 1 byte for each sample} procedure TChunkIDAT.CopyInterlacedRGBAlpha8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; - Dest := pByte(Longint(Dest) + Col * 3); - Trans := pByte(Longint(Trans) + Col); + Dest := pChar(Longint(Dest) + Col * 3); + Trans := pChar(Longint(Trans) + Col); repeat {Copy this row and alpha value} - Trans^ := pByte(Longint(Src) + 3)^; - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + Trans^ := pChar(Longint(Src) + 3)^; + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); {Move to next column} inc(Src, 4); @@ -2755,25 +2947,25 @@ procedure TChunkIDAT.CopyInterlacedRGBAlpha8(const Pass: Byte; {Decodes interlaced RGB alpha with 2 bytes for each sample} procedure TChunkIDAT.CopyInterlacedRGBAlpha16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; - Dest := pByte(Longint(Dest) + Col * 3); - Trans := pByte(Longint(Trans) + Col); + Dest := pChar(Longint(Dest) + Col * 3); + Trans := pChar(Longint(Trans) + Col); repeat {Copy this row and alpha value} - Trans^ := pByte(Longint(Src) + 6)^; - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + Trans^ := pChar(Longint(Src) + 6)^; + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); {$IFDEF Store16bits} {Copy extra pixel values} - PByte(Extra)^ := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); - PByte(Extra)^ := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); - PByte(Extra)^ := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); {$ENDIF} {Move to next column} @@ -2786,14 +2978,14 @@ procedure TChunkIDAT.CopyInterlacedRGBAlpha16(const Pass: Byte; {Decodes 8 bit grayscale image followed by an alpha sample} procedure TChunkIDAT.CopyInterlacedGrayscaleAlpha8(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var Col: Integer; begin {Get first column, pointers to the data and enter in loop} Col := ColumnStart[Pass]; - Dest := pByte(Longint(Dest) + Col); - Trans := pByte(Longint(Trans) + Col); + Dest := pChar(Longint(Dest) + Col); + Trans := pChar(Longint(Trans) + Col); repeat {Copy this grayscale value and alpha} Dest^ := Src^; inc(Src); @@ -2808,17 +3000,17 @@ procedure TChunkIDAT.CopyInterlacedGrayscaleAlpha8(const Pass: Byte; {Decodes 16 bit grayscale image followed by an alpha sample} procedure TChunkIDAT.CopyInterlacedGrayscaleAlpha16(const Pass: Byte; - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var Col: Integer; begin {Get first column, pointers to the data and enter in loop} Col := ColumnStart[Pass]; - Dest := pByte(Longint(Dest) + Col); - Trans := pByte(Longint(Trans) + Col); + Dest := pChar(Longint(Dest) + Col); + Trans := pChar(Longint(Trans) + Col); repeat {$IFDEF Store16bits} - Extra^ := pByte(Longint(Src) + 1)^; inc(Extra); + Extra^ := pChar(Longint(Src) + 1)^; inc(Extra); {$ENDIF} {Copy this grayscale value and alpha, transforming 16 bits into 8} Dest^ := Src^; inc(Src, 2); @@ -2838,9 +3030,9 @@ procedure TChunkIDAT.DecodeInterlacedAdam7(Stream: TStream; CurrentPass: Byte; PixelsThisRow: Integer; CurrentRow: Integer; - Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pByte; + Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pChar; CopyProc: procedure(const Pass: Byte; Src, Dest, - Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte) of object; + Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar) of object; begin CopyProc := nil; {Initialize} @@ -2930,16 +3122,16 @@ procedure TChunkIDAT.DecodeInterlacedAdam7(Stream: TStream; {Copy 8 bits RGB image} procedure TChunkIDAT.CopyNonInterlacedRGB8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var I: Integer; begin FOR I := 1 TO ImageWidth DO begin {Copy pixel values} - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); {Move to next pixel} inc(Src, 3); end {for I} @@ -2947,7 +3139,7 @@ procedure TChunkIDAT.CopyNonInterlacedRGB8( {Copy 16 bits RGB image} procedure TChunkIDAT.CopyNonInterlacedRGB16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var I: Integer; begin @@ -2956,14 +3148,14 @@ procedure TChunkIDAT.CopyNonInterlacedRGB16( //Since windows does not supports 2 bytes for //each R, G, B value, the method will read only 1 byte from it {Copy pixel values} - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); {$IFDEF Store16bits} {Copy extra pixel values} - PByte(Extra)^ := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); - PByte(Extra)^ := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); - PByte(Extra)^ := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); {$ENDIF} {Move to next pixel} @@ -2973,7 +3165,7 @@ procedure TChunkIDAT.CopyNonInterlacedRGB16( {Copy types using palettes (1, 4 or 8 bits per pixel)} procedure TChunkIDAT.CopyNonInterlacedPalette148( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); begin {It's simple as copying the data} CopyMemory(Dest, Src, Row_Bytes); @@ -2981,16 +3173,16 @@ procedure TChunkIDAT.CopyNonInterlacedPalette148( {Copy grayscale types using 2 bits for each pixel} procedure TChunkIDAT.CopyNonInterlacedGray2( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var i: Integer; begin {2 bits is not supported, this routine will converted into 4 bits} FOR i := 1 TO Row_Bytes do begin - PByte(Dest)^ := ((Byte(Src^) shr 2) and $F) or ((Byte(Src^)) and $F0); + Byte(Dest^) := ((Byte(Src^) shr 2) and $F) or ((Byte(Src^)) and $F0); inc(Dest); - PByte(Dest)^ := ((Byte(Src^) shl 2) and $F) or ((Byte(Src^) shl 4) and $F0); + Byte(Dest^) := ((Byte(Src^) shl 2) and $F) or ((Byte(Src^) shl 4) and $F0); inc(Dest); inc(Src); end {FOR i} @@ -2998,16 +3190,16 @@ procedure TChunkIDAT.CopyNonInterlacedGray2( {Copy types using palette with 2 bits for each pixel} procedure TChunkIDAT.CopyNonInterlacedPalette2( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var i: Integer; begin {2 bits is not supported, this routine will converted into 4 bits} FOR i := 1 TO Row_Bytes do begin - PByte(Dest)^ := ((Byte(Src^) shr 4) and $3) or ((Byte(Src^) shr 2) and $30); + Byte(Dest^) := ((Byte(Src^) shr 4) and $3) or ((Byte(Src^) shr 2) and $30); inc(Dest); - PByte(Dest)^ := (Byte(Src^) and $3) or ((Byte(Src^) shl 2) and $30); + Byte(Dest^) := (Byte(Src^) and $3) or ((Byte(Src^) shl 2) and $30); inc(Dest); inc(Src); end {FOR i} @@ -3015,7 +3207,7 @@ procedure TChunkIDAT.CopyNonInterlacedPalette2( {Copy grayscale images with 16 bits} procedure TChunkIDAT.CopyNonInterlacedGrayscale16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var I: Integer; begin @@ -3025,7 +3217,7 @@ procedure TChunkIDAT.CopyNonInterlacedGrayscale16( {mode, so reduce to 8} Dest^ := Src^; inc(Dest); {$IFDEF Store16bits} - Extra^ := pByte(Longint(Src) + 1)^; inc(Extra); + Extra^ := pChar(Longint(Src) + 1)^; inc(Extra); {$ENDIF} {Move to next pixel} @@ -3035,17 +3227,17 @@ procedure TChunkIDAT.CopyNonInterlacedGrayscale16( {Copy 8 bits per sample RGB images followed by an alpha byte} procedure TChunkIDAT.CopyNonInterlacedRGBAlpha8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var i: Integer; begin FOR I := 1 TO ImageWidth DO begin {Copy pixel values and transparency} - Trans^ := pByte(Longint(Src) + 3)^; - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + Trans^ := pChar(Longint(Src) + 3)^; + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); {Move to next pixel} inc(Src, 4); inc(Trans); end {for I} @@ -3053,7 +3245,7 @@ procedure TChunkIDAT.CopyNonInterlacedRGBAlpha8( {Copy 16 bits RGB image with alpha using 2 bytes for each sample} procedure TChunkIDAT.CopyNonInterlacedRGBAlpha16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var I: Integer; begin @@ -3061,15 +3253,15 @@ procedure TChunkIDAT.CopyNonInterlacedRGBAlpha16( begin //Copy rgb and alpha values (transforming from 16 bits to 8 bits) {Copy pixel values} - Trans^ := pByte(Longint(Src) + 6)^; - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); - PByte(Dest)^ := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); + Trans^ := pChar(Longint(Src) + 6)^; + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 4)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.GammaTable[pByte(Longint(Src) )^]; inc(Dest); {$IFDEF Store16bits} {Copy extra pixel values} - PByte(Extra)^ := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); - PByte(Extra)^ := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); - PByte(Extra)^ := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 5)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 3)^]; inc(Extra); + Byte(Extra^) := fOwner.GammaTable[pByte(Longint(Src) + 1)^]; inc(Extra); {$ENDIF} {Move to next pixel} inc(Src, 8); inc(Trans); @@ -3078,7 +3270,7 @@ procedure TChunkIDAT.CopyNonInterlacedRGBAlpha16( {Copy 8 bits per sample grayscale followed by alpha} procedure TChunkIDAT.CopyNonInterlacedGrayscaleAlpha8( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var I: Integer; begin @@ -3093,7 +3285,7 @@ procedure TChunkIDAT.CopyNonInterlacedGrayscaleAlpha8( {Copy 16 bits per sample grayscale followed by alpha} procedure TChunkIDAT.CopyNonInterlacedGrayscaleAlpha16( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte); + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar); var I: Integer; begin @@ -3101,7 +3293,7 @@ procedure TChunkIDAT.CopyNonInterlacedGrayscaleAlpha16( begin {Copy alpha value and then gray value} {$IFDEF Store16bits} - Extra^ := pByte(Longint(Src) + 1)^; inc(Extra); + Extra^ := pChar(Longint(Src) + 1)^; inc(Extra); {$ENDIF} Dest^ := Src^; inc(Src, 2); Trans^ := Src^; inc(Src, 2); @@ -3114,9 +3306,9 @@ procedure TChunkIDAT.DecodeNonInterlaced(Stream: TStream; var ZLIBStream: TZStreamRec2; const Size: Integer; var crcfile: Cardinal); var j: Cardinal; - Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pByte; + Trans, Data{$IFDEF Store16bits}, Extra{$ENDIF}: pChar; CopyProc: procedure( - Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pByte) of object; + Src, Dest, Trans{$IFDEF Store16bits}, Extra{$ENDIF}: pChar) of object; begin CopyProc := nil; {Initialize} {Determines the method to copy the image data} @@ -3313,7 +3505,7 @@ function TChunkIDAT.LoadFromStream(Stream: TStream; const ChunkName: TChunkName; end; const - IDATHeader: Array[0..3] of AnsiChar = ('I', 'D', 'A', 'T'); + IDATHeader: Array[0..3] of char = ('I', 'D', 'A', 'T'); BUFFER = 5; {Saves the IDAT chunk to a stream} @@ -3446,23 +3638,23 @@ procedure TChunkIDAT.FinishIDATZlib(var ZLIBStream: TZStreamRec2); end; {Copy memory to encode RGB image with 1 byte for each color sample} -procedure TChunkIDAT.EncodeNonInterlacedRGB8(Src, Dest, Trans: pByte); +procedure TChunkIDAT.EncodeNonInterlacedRGB8(Src, Dest, Trans: pChar); var I: Integer; begin FOR I := 1 TO ImageWidth DO begin {Copy pixel values} - PByte(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest); - PByte(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest); - PByte(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest); + Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest); {Move to next pixel} inc(Src, 3); end {for I} end; {Copy memory to encode RGB images with 16 bits for each color sample} -procedure TChunkIDAT.EncodeNonInterlacedRGB16(Src, Dest, Trans: pByte); +procedure TChunkIDAT.EncodeNonInterlacedRGB16(Src, Dest, Trans: pChar); var I: Integer; begin @@ -3481,14 +3673,14 @@ procedure TChunkIDAT.EncodeNonInterlacedRGB16(Src, Dest, Trans: pByte); end; {Copy memory to encode types using palettes (1, 4 or 8 bits per pixel)} -procedure TChunkIDAT.EncodeNonInterlacedPalette148(Src, Dest, Trans: pByte); +procedure TChunkIDAT.EncodeNonInterlacedPalette148(Src, Dest, Trans: pChar); begin {It's simple as copying the data} CopyMemory(Dest, Src, Row_Bytes); end; {Copy memory to encode grayscale images with 2 bytes for each sample} -procedure TChunkIDAT.EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pByte); +procedure TChunkIDAT.EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pChar); var I: Integer; begin @@ -3503,23 +3695,23 @@ procedure TChunkIDAT.EncodeNonInterlacedGrayscale16(Src, Dest, Trans: pByte); end; {Encode images using RGB followed by an alpha value using 1 byte for each} -procedure TChunkIDAT.EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pByte); +procedure TChunkIDAT.EncodeNonInterlacedRGBAlpha8(Src, Dest, Trans: pChar); var i: Integer; begin {Copy the data to the destination, including data from Trans pointer} FOR i := 1 TO ImageWidth do begin - PByte(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) + 2)^]; inc(Dest); - PByte(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) + 1)^]; inc(Dest); - PByte(Dest)^ := Owner.InverseGamma[PByte(Longint(Src) )^]; inc(Dest); + Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := Owner.InverseGamma[PByte(Longint(Src) )^]; inc(Dest); Dest^ := Trans^; inc(Dest); inc(Src, 3); inc(Trans); end {for i}; end; {Encode images using RGB followed by an alpha value using 2 byte for each} -procedure TChunkIDAT.EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pByte); +procedure TChunkIDAT.EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pChar); var i: Integer; begin @@ -3536,7 +3728,7 @@ procedure TChunkIDAT.EncodeNonInterlacedRGBAlpha16(Src, Dest, Trans: pByte); {Encode grayscale images followed by an alpha value using 1 byte for each} procedure TChunkIDAT.EncodeNonInterlacedGrayscaleAlpha8( - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); var i: Integer; begin @@ -3551,7 +3743,7 @@ procedure TChunkIDAT.EncodeNonInterlacedGrayscaleAlpha8( {Encode grayscale images followed by an alpha value using 2 byte for each} procedure TChunkIDAT.EncodeNonInterlacedGrayscaleAlpha16( - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); var i: Integer; begin @@ -3571,11 +3763,11 @@ procedure TChunkIDAT.EncodeNonInterlaced(Stream: TStream; {Current line} j: Cardinal; {Pointers to image data} - Data, Trans: pByte; + Data, Trans: PChar; {Filter used for this line} Filter: Byte; {Method which will copy the data into the buffer} - CopyProc: procedure(Src, Dest, Trans: pByte) of object; + CopyProc: procedure(Src, Dest, Trans: pChar) of object; begin CopyProc := nil; {Initialize to avoid warnings} {Defines the method to copy the data to the buffer depending on} @@ -3636,18 +3828,18 @@ procedure TChunkIDAT.EncodeNonInterlaced(Stream: TStream; {Copy memory to encode interlaced images using RGB value with 1 byte for} {each color sample} procedure TChunkIDAT.EncodeInterlacedRGB8(const Pass: Byte; - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; - Src := pByte(Longint(Src) + Col * 3); + Src := pChar(Longint(Src) + Col * 3); repeat {Copy this row} - PByte(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest); - PByte(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest); - PByte(Dest)^ := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest); + Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := fOwner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest); {Move to next column} inc(Src, ColumnIncrement[Pass] * 3); @@ -3657,13 +3849,13 @@ procedure TChunkIDAT.EncodeInterlacedRGB8(const Pass: Byte; {Copy memory to encode interlaced RGB images with 2 bytes each color sample} procedure TChunkIDAT.EncodeInterlacedRGB16(const Pass: Byte; - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; - Src := pByte(Longint(Src) + Col * 3); + Src := pChar(Longint(Src) + Col * 3); repeat {Copy this row} pWord(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest, 2); @@ -3679,13 +3871,13 @@ procedure TChunkIDAT.EncodeInterlacedRGB16(const Pass: Byte; {Copy memory to encode interlaced images using palettes using bit depths} {1, 4, 8 (each pixel in the image)} procedure TChunkIDAT.EncodeInterlacedPalette148(const Pass: Byte; - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); const BitTable: Array[1..8] of Integer = ($1, $3, 0, $F, 0, 0, 0, $FF); StartBit: Array[1..8] of Integer = (7 , 0 , 0, 4, 0, 0, 0, 0); var CurBit, Col: Integer; - Src2: pByte; + Src2: PChar; begin {Clean the line} fillchar(Dest^, Row_Bytes, #0); @@ -3697,9 +3889,9 @@ procedure TChunkIDAT.EncodeInterlacedPalette148(const Pass: Byte; CurBit := StartBit[biBitCount]; repeat {Adjust pointer to pixel byte bounds} - Src2 := pByte(Longint(Src) + (biBitCount * Col) div 8); + Src2 := pChar(Longint(Src) + (biBitCount * Col) div 8); {Copy data} - PByte(Dest)^ := Byte(Dest^) or + Byte(Dest^) := Byte(Dest^) or (((Byte(Src2^) shr (StartBit[Header.BitDepth] - (biBitCount * Col) mod 8))) and (BitTable[biBitCount])) shl CurBit; @@ -3716,13 +3908,13 @@ procedure TChunkIDAT.EncodeInterlacedPalette148(const Pass: Byte; {Copy to encode interlaced grayscale images using 16 bits for each sample} procedure TChunkIDAT.EncodeInterlacedGrayscale16(const Pass: Byte; - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; - Src := pByte(Longint(Src) + Col); + Src := pChar(Longint(Src) + Col); repeat {Copy this row} pWord(Dest)^ := Byte(Src^); inc(Dest, 2); @@ -3736,19 +3928,19 @@ procedure TChunkIDAT.EncodeInterlacedGrayscale16(const Pass: Byte; {Copy to encode interlaced rgb images followed by an alpha value, all using} {one byte for each sample} procedure TChunkIDAT.EncodeInterlacedRGBAlpha8(const Pass: Byte; - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; - Src := pByte(Longint(Src) + Col * 3); - Trans := pByte(Longint(Trans) + Col); + Src := pChar(Longint(Src) + Col * 3); + Trans := pChar(Longint(Trans) + Col); repeat {Copy this row} - PByte(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest); - PByte(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest); - PByte(Dest)^ := Owner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest); + Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) + 2)^]; inc(Dest); + Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) + 1)^]; inc(Dest); + Byte(Dest^) := Owner.InverseGamma[pByte(Longint(Src) )^]; inc(Dest); Dest^ := Trans^; inc(Dest); {Move to next column} @@ -3761,14 +3953,14 @@ procedure TChunkIDAT.EncodeInterlacedRGBAlpha8(const Pass: Byte; {Copy to encode interlaced rgb images followed by an alpha value, all using} {two byte for each sample} procedure TChunkIDAT.EncodeInterlacedRGBAlpha16(const Pass: Byte; - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; - Src := pByte(Longint(Src) + Col * 3); - Trans := pByte(Longint(Trans) + Col); + Src := pChar(Longint(Src) + Col * 3); + Trans := pChar(Longint(Trans) + Col); repeat {Copy this row} pWord(Dest)^ := pByte(Longint(Src) + 2)^; inc(Dest, 2); @@ -3786,14 +3978,14 @@ procedure TChunkIDAT.EncodeInterlacedRGBAlpha16(const Pass: Byte; {Copy to encode grayscale interlaced images followed by an alpha value, all} {using 1 byte for each sample} procedure TChunkIDAT.EncodeInterlacedGrayscaleAlpha8(const Pass: Byte; - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; - Src := pByte(Longint(Src) + Col); - Trans := pByte(Longint(Trans) + Col); + Src := pChar(Longint(Src) + Col); + Trans := pChar(Longint(Trans) + Col); repeat {Copy this row} Dest^ := Src^; inc(Dest); @@ -3809,14 +4001,14 @@ procedure TChunkIDAT.EncodeInterlacedGrayscaleAlpha8(const Pass: Byte; {Copy to encode grayscale interlaced images followed by an alpha value, all} {using 2 bytes for each sample} procedure TChunkIDAT.EncodeInterlacedGrayscaleAlpha16(const Pass: Byte; - Src, Dest, Trans: pByte); + Src, Dest, Trans: pChar); var Col: Integer; begin {Get first column and enter in loop} Col := ColumnStart[Pass]; - Src := pByte(Longint(Src) + Col); - Trans := pByte(Longint(Trans) + Col); + Src := pChar(Longint(Src) + Col); + Trans := pChar(Longint(Trans) + Col); repeat {Copy this row} pWord(Dest)^ := pByte(Src)^; inc(Dest, 2); @@ -3836,9 +4028,9 @@ procedure TChunkIDAT.EncodeInterlacedAdam7(Stream: TStream; CurrentPass, Filter: Byte; PixelsThisRow: Integer; CurrentRow : Integer; - Trans, Data: pByte; + Trans, Data: pChar; CopyProc: procedure(const Pass: Byte; - Src, Dest, Trans: pByte) of object; + Src, Dest, Trans: pChar) of object; begin CopyProc := nil; {Initialize to avoid warnings} {Defines the method to copy the data to the buffer depending on} @@ -3919,7 +4111,7 @@ function TChunkIDAT.FilterToEncode: Byte; Run, LongestRun, ii, jj: Cardinal; Last, Above, LastAbove: Byte; begin - {Selecting more filters using the Filters property from TPngImage} + {Selecting more filters using the Filters property from TPngObject} {increases the chances to the file be much smaller, but decreases} {the performace} @@ -4142,7 +4334,7 @@ procedure TChunkgAMA.Assign(Source: TChunk); end; {Gamma chunk being created} -constructor TChunkgAMA.Create(Owner: TPngImage); +constructor TChunkgAMA.Create(Owner: TPngObject); begin {Call ancestor} inherited Create(Owner); @@ -4204,17 +4396,17 @@ procedure TChunkgAMA.SetValue(const Value: Cardinal); pCardinal(Data)^ := ByteSwap(Value); end; -{TPngImage implementation} +{TPngObject implementation} {Assigns from another object} -procedure TPngImage.Assign(Source: TPersistent); +procedure TPngObject.Assign(Source: TPersistent); begin {Being cleared} if Source = nil then ClearChunks - {Assigns contents from another TPngImage} - else if Source is TPngImage then - AssignPNG(Source as TPngImage) + {Assigns contents from another TPNGObject} + else if Source is TPNGObject then + AssignPNG(Source as TPNGObject) {Copy contents from a TBitmap} {$IFDEF UseDelphi}else if Source is TBitmap then with Source as TBitmap do @@ -4226,7 +4418,7 @@ procedure TPngImage.Assign(Source: TPersistent); end; {Clear all the chunks in the list} -procedure TPngImage.ClearChunks; +procedure TPngObject.ClearChunks; var i: Integer; begin @@ -4239,7 +4431,7 @@ procedure TPngImage.ClearChunks; end; {Portable Network Graphics object being created as a blank image} -constructor TPngImage.CreateBlank(ColorType, BitDepth: Cardinal; +constructor TPNGObject.CreateBlank(ColorType, BitDepth: Cardinal; cx, cy: Integer); var NewIHDR: TChunkIHDR; begin @@ -4273,7 +4465,7 @@ constructor TPngImage.CreateBlank(ColorType, BitDepth: Cardinal; end; {Portable Network Graphics object being created} -constructor TPngImage.Create; +constructor TPngObject.Create; begin {Let it be created} inherited Create; @@ -4290,7 +4482,7 @@ constructor TPngImage.Create; end; {Portable Network Graphics object being destroyed} -destructor TPngImage.Destroy; +destructor TPngObject.Destroy; begin {Free object list} ClearChunks; @@ -4303,7 +4495,7 @@ destructor TPngImage.Destroy; end; {Returns linesize and byte offset for pixels} -procedure TPngImage.GetPixelInfo(var LineSize, Offset: Cardinal); +procedure TPngObject.GetPixelInfo(var LineSize, Offset: Cardinal); begin {There must be an Header chunk to calculate size} if HeaderPresent then @@ -4346,7 +4538,7 @@ procedure TPngImage.GetPixelInfo(var LineSize, Offset: Cardinal); end; {Returns image height} -function TPngImage.GetHeight: Integer; +function TPngObject.GetHeight: Integer; begin {There must be a Header chunk to get the size, otherwise returns 0} if HeaderPresent then @@ -4355,7 +4547,7 @@ function TPngImage.GetHeight: Integer; end; {Returns image width} -function TPngImage.GetWidth: Integer; +function TPngObject.GetWidth: Integer; begin {There must be a Header chunk to get the size, otherwise returns 0} if HeaderPresent then @@ -4364,19 +4556,19 @@ function TPngImage.GetWidth: Integer; end; {Returns if the image is empty} -function TPngImage.GetEmpty: Boolean; +function TPngObject.GetEmpty: Boolean; begin Result := (Chunks.Count = 0); end; {Raises an error} -procedure TPngImage.RaiseError(ExceptionClass: ExceptClass; Text: String); +procedure TPngObject.RaiseError(ExceptionClass: ExceptClass; Text: String); begin raise ExceptionClass.Create(Text); end; {Set the maximum size for IDAT chunk} -procedure TPngImage.SetMaxIdatSize(const Value: Integer); +procedure TPngObject.SetMaxIdatSize(const Value: Integer); begin {Make sure the size is at least 65535} if Value < High(Word) then @@ -4384,7 +4576,7 @@ procedure TPngImage.SetMaxIdatSize(const Value: Integer); end; {Draws the image using pixel information from TChunkpHYs} -procedure TPngImage.DrawUsingPixelInformation(Canvas: TCanvas; Point: TPoint); +procedure TPNGObject.DrawUsingPixelInformation(Canvas: TCanvas; Point: TPoint); function Rect(Left, Top, Right, Bottom: Integer): TRect; begin Result.Left := Left; @@ -4419,7 +4611,7 @@ procedure TPngImage.DrawUsingPixelInformation(Canvas: TCanvas; Point: TPoint); {$IFNDEF UseDelphi} {Creates a file stream reading from the filename in the parameter and load} - procedure TPngImage.LoadFromFile(const Filename: String); + procedure TPngObject.LoadFromFile(const Filename: String); var FileStream: TFileStream; begin @@ -4438,7 +4630,7 @@ procedure TPngImage.DrawUsingPixelInformation(Canvas: TCanvas; Point: TPoint); end; {Saves the current png image to a file} - procedure TPngImage.SaveToFile(const Filename: String); + procedure TPngObject.SaveToFile(const Filename: String); var FileStream: TFileStream; begin @@ -4451,13 +4643,13 @@ procedure TPngImage.DrawUsingPixelInformation(Canvas: TCanvas; Point: TPoint); {$ENDIF} {Returns if it has the pixel information chunk} -function TPngImage.HasPixelInformation: Boolean; +function TPngObject.HasPixelInformation: Boolean; begin Result := (Chunks.ItemFromClass(TChunkpHYs) as tChunkpHYs) <> nil; end; {Returns the pixel information chunk} -function TPngImage.GetPixelInformation: TChunkpHYs; +function TPngObject.GetPixelInformation: TChunkpHYs; begin Result := Chunks.ItemFromClass(TChunkpHYs) as tChunkpHYs; if not Assigned(Result) then @@ -4468,7 +4660,7 @@ function TPngImage.GetPixelInformation: TChunkpHYs; end; {Returns pointer to the chunk TChunkIHDR which should be the first} -function TPngImage.GetHeader: TChunkIHDR; +function TPngObject.GetHeader: TChunkIHDR; begin {If there is a TChunkIHDR returns it, otherwise returns nil} if (Chunks.Count <> 0) and (Chunks.Item[0] is TChunkIHDR) then @@ -4482,7 +4674,7 @@ function TPngImage.GetHeader: TChunkIHDR; end; {Draws using partial transparency} -procedure TPngImage.DrawPartialTrans(DC: HDC; Rect: TRect); +procedure TPngObject.DrawPartialTrans(DC: HDC; Rect: TRect); {Adjust the rectangle structure} procedure AdjustRect(var Rect: TRect); var @@ -4614,20 +4806,16 @@ procedure TPngImage.DrawPartialTrans(DC: HDC; Rect: TRect); {Optmize when we don´t have transparency} if (AlphaSource[i2] <> 0) then if (AlphaSource[i2] = 255) then - begin - pRGBTriple(@ImageData[i])^ := pRGBTriple(@ImageSource[i2 * 3])^; - ImageData[i].rgbReserved := 255; - end + ImageData[i] := pRGBQuad(@ImageSource[i2 * 3])^ else with ImageData[i] do begin - rgbRed := ($7F + ImageSource[2+i2*3] * AlphaSource[i2] + rgbRed * - (not AlphaSource[i2])) div $FF; - rgbGreen := ($7F + ImageSource[1+i2*3] * AlphaSource[i2] + - rgbGreen * (not AlphaSource[i2])) div $FF; - rgbBlue := ($7F + ImageSource[i2*3] * AlphaSource[i2] + rgbBlue * - (not AlphaSource[i2])) div $FF; - rgbReserved := not (($7F + (not rgbReserved) * (not AlphaSource[i2])) div $FF); + rgbRed := (255+ImageSource[2+i2*3] * AlphaSource[i2] + rgbRed * + (not AlphaSource[i2])) shr 8; + rgbGreen := (255+ImageSource[1+i2*3] * AlphaSource[i2] + + rgbGreen * (not AlphaSource[i2])) shr 8; + rgbBlue := (255+ImageSource[i2*3] * AlphaSource[i2] + rgbBlue * + (not AlphaSource[i2])) shr 8; end; end; @@ -4646,13 +4834,12 @@ procedure TPngImage.DrawPartialTrans(DC: HDC; Rect: TRect); FOR i := 0 TO W - 1 DO with ImageData[i], Header.BitmapInfo do begin if Stretch then i2 := trunc(i / FactorX) else i2 := i; - rgbRed := ($7F + ImageSource[i2] * AlphaSource[i2] + - rgbRed * (not AlphaSource[i2])) div $FF; - rgbGreen := ($7F + ImageSource[i2] * AlphaSource[i2] + - rgbGreen * (not AlphaSource[i2])) div $FF; - rgbBlue := ($7F + ImageSource[i2] * AlphaSource[i2] + - rgbBlue * (not AlphaSource[i2])) div $FF; - rgbReserved := not (($7F + (not rgbReserved) * (not AlphaSource[i2])) div $FF); + rgbRed := (255 + ImageSource[i2] * AlphaSource[i2] + + rgbRed * (255 - AlphaSource[i2])) shr 8; + rgbGreen := (255 + ImageSource[i2] * AlphaSource[i2] + + rgbGreen * (255 - AlphaSource[i2])) shr 8; + rgbBlue := (255 + ImageSource[i2] * AlphaSource[i2] + + rgbBlue * (255 - AlphaSource[i2])) shr 8; end; {Move pointers} @@ -4722,7 +4909,7 @@ procedure TPngImage.DrawPartialTrans(DC: HDC; Rect: TRect); end; {Draws the image into a canvas} -procedure TPngImage.Draw(ACanvas: TCanvas; const Rect: TRect); +procedure TPngObject.Draw(ACanvas: TCanvas; const Rect: TRect); var Header: TChunkIHDR; begin @@ -4754,12 +4941,12 @@ procedure TPngImage.Draw(ACanvas: TCanvas; const Rect: TRect); {Characters for the header} const - PngHeader: Array[0..7] of AnsiChar = (#137, #80, #78, #71, #13, #10, #26, #10); + PngHeader: Array[0..7] of Char = (#137, #80, #78, #71, #13, #10, #26, #10); {Loads the image from a stream of data} -procedure TPngImage.LoadFromStream(Stream: TStream); +procedure TPngObject.LoadFromStream(Stream: TStream); var - Header : Array[0..7] of AnsiChar; + Header : Array[0..7] of Char; HasIDAT : Boolean; {Chunks reading} @@ -4857,20 +5044,20 @@ procedure TPngImage.LoadFromStream(Stream: TStream); end; {Changing height is not supported} -procedure TPngImage.SetHeight(Value: Integer); +procedure TPngObject.SetHeight(Value: Integer); begin Resize(Width, Value) end; {Changing width is not supported} -procedure TPngImage.SetWidth(Value: Integer); +procedure TPngObject.SetWidth(Value: Integer); begin Resize(Value, Height) end; {$IFDEF UseDelphi} {Saves to clipboard format (thanks to Antoine Pottern)} -procedure TPngImage.SaveToClipboardFormat(var AFormat: Word; +procedure TPNGObject.SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPalette); begin with TBitmap.Create do @@ -4885,7 +5072,7 @@ procedure TPngImage.SaveToClipboardFormat(var AFormat: Word; end; {Loads data from clipboard} -procedure TPngImage.LoadFromClipboardFormat(AFormat: Word; +procedure TPngObject.LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPalette); begin with TBitmap.Create do @@ -4898,7 +5085,7 @@ procedure TPngImage.LoadFromClipboardFormat(AFormat: Word; end; {Returns if the image is transparent} -function TPngImage.GetTransparent: Boolean; +function TPngObject.GetTransparent: Boolean; begin Result := (TransparencyMode <> ptmNone); end; @@ -4906,7 +5093,7 @@ function TPngImage.GetTransparent: Boolean; {$ENDIF} {Saving the PNG image to a stream of data} -procedure TPngImage.SaveToStream(Stream: TStream); +procedure TPngObject.SaveToStream(Stream: TStream); var j: Integer; begin @@ -4946,7 +5133,7 @@ procedure BuildHeader(Header: TChunkIHDR; Handle: HBitmap; Info: pBitmap); end; {Loads the image from a resource} -procedure TPngImage.LoadFromResourceName(Instance: HInst; +procedure TPngObject.LoadFromResourceName(Instance: HInst; const Name: String); var ResStream: TResourceStream; @@ -4965,13 +5152,13 @@ procedure TPngImage.LoadFromResourceName(Instance: HInst; end; {Loads the png from a resource ID} -procedure TPngImage.LoadFromResourceID(Instance: HInst; ResID: Integer); +procedure TPngObject.LoadFromResourceID(Instance: HInst; ResID: Integer); begin LoadFromResourceName(Instance, String(ResID)); end; -{Assigns this TPngImage to another object} -procedure TPngImage.AssignTo(Dest: TPersistent); +{Assigns this tpngobject to another object} +procedure TPngObject.AssignTo(Dest: TPersistent); {$IFDEF UseDelphi} function DetectPixelFormat: TPixelFormat; begin @@ -4998,48 +5185,30 @@ procedure TPngImage.AssignTo(Dest: TPersistent); end; var TRNS: TChunkTRNS; - I, J: Integer; {$ENDIF} begin - {If the destination is also a TPngImage make it assign} + {If the destination is also a TPNGObject make it assign} {this one} - if Dest is TPngImage then - TPngImage(Dest).AssignPNG(Self) + if Dest is TPNGObject then + TPNGObject(Dest).AssignPNG(Self) {$IFDEF UseDelphi} {In case the destination is a bitmap} else if (Dest is TBitmap) and HeaderPresent then begin - TBitmap(Dest).SetSize(Width, Height); - - if (TransparencyMode = ptmPartial) then - begin - TBitmap(Dest).PixelFormat := pf32bit; - TBitmap(Dest).AlphaFormat := afDefined; - TBitmap(Dest).Canvas.Brush.Color := 0; - TBitmap(Dest).Canvas.FillRect(Bounds(0,0,Width, Height)); - end - else - begin - TBitmap(Dest).PixelFormat := DetectPixelFormat; - TBitmap(Dest).AlphaFormat := afIgnored; - end; - - if Palette <> 0 then - TBitmap(Dest).Palette := CopyPalette(Palette); + {Copies the handle using CopyImage API} + TBitmap(Dest).PixelFormat := DetectPixelFormat; + TBitmap(Dest).Width := Width; + TBitmap(Dest).Height := Height; + TBitmap(Dest).Canvas.Draw(0, 0, Self); + {Copy transparency mode} if (TransparencyMode = ptmBit) then begin TRNS := Chunks.ItemFromClass(TChunkTRNS) as TChunkTRNS; TBitmap(Dest).TransparentColor := TRNS.TransparentColor; - TBitmap(Dest).Transparent := True; - SetStretchBltMode(TBitmap(Dest).Canvas.Handle, COLORONCOLOR); - StretchDiBits(TBitmap(Dest).Canvas.Handle, 0, 0, Width, Height, 0, 0, - Width, Height, Header.ImageData, - pBitmapInfo(@Header.BitmapInfo)^, DIB_RGB_COLORS, SRCCOPY) - + TBitmap(Dest).Transparent := True end {if (TransparencyMode = ptmBit)} - else - TBitmap(Dest).Canvas.Draw(0, 0, Self); + end else {Unknown destination kind} @@ -5048,7 +5217,7 @@ procedure TPngImage.AssignTo(Dest: TPersistent); end; {Assigns from a bitmap object} -procedure TPngImage.AssignHandle(Handle: HBitmap; Transparent: Boolean; +procedure TPngObject.AssignHandle(Handle: HBitmap; Transparent: Boolean; TransparentColor: ColorRef); var BitmapInfo: Windows.TBitmap; @@ -5110,7 +5279,7 @@ procedure TPngImage.AssignHandle(Handle: HBitmap; Transparent: Boolean; end; {Assigns from another PNG} -procedure TPngImage.AssignPNG(Source: TPngImage); +procedure TPngObject.AssignPNG(Source: TPNGObject); var J: Integer; begin @@ -5130,12 +5299,10 @@ procedure TPngImage.AssignPNG(Source: TPngImage); Chunks.SetItem(J, TChunkClass(TChunk(Item[J]).ClassType).Create(Self)); TChunk(Chunks.Item[J]).Assign(TChunk(Item[J])); end {with}; - - InverseGamma := Source.InverseGamma; end; {Returns a alpha data scanline} -function TPngImage.GetAlphaScanline(const LineIndex: Integer): pByteArray; +function TPngObject.GetAlphaScanline(const LineIndex: Integer): pByteArray; begin with Header do if (ColorType = COLOR_RGBALPHA) or (ColorType = COLOR_GRAYSCALEALPHA) then @@ -5145,7 +5312,7 @@ function TPngImage.GetAlphaScanline(const LineIndex: Integer): pByteArray; {$IFDEF Store16bits} {Returns a png data extra scanline} -function TPngImage.GetExtraScanline(const LineIndex: Integer): Pointer; +function TPngObject.GetExtraScanline(const LineIndex: Integer): Pointer; begin with Header do Longint(Result) := (Longint(ExtraImageData) + ((Longint(Height) - 1) * @@ -5154,20 +5321,15 @@ function TPngImage.GetExtraScanline(const LineIndex: Integer): Pointer; {$ENDIF} {Returns a png data scanline} -function TPngImage.GetScanline(const LineIndex: Integer): Pointer; +function TPngObject.GetScanline(const LineIndex: Integer): Pointer; begin with Header do Longint(Result) := (Longint(ImageData) + ((Longint(Height) - 1) * BytesPerRow)) - (LineIndex * BytesPerRow); end; -function TPngImage.GetSupportsPartialTransparency: Boolean; -begin - Result := TransparencyMode = ptmPartial; -end; - {Initialize gamma table} -procedure TPngImage.InitializeGamma; +procedure TPngObject.InitializeGamma; var i: Integer; begin @@ -5180,7 +5342,7 @@ procedure TPngImage.InitializeGamma; end; {Returns the transparency mode used by this png} -function TPngImage.GetTransparencyMode: TPNGTransparencyMode; +function TPngObject.GetTransparencyMode: TPNGTransparencyMode; var TRNS: TChunkTRNS; begin @@ -5208,7 +5370,7 @@ function TPngImage.GetTransparencyMode: TPNGTransparencyMode; end; {Add a text chunk} -procedure TPngImage.AddtEXt(const Keyword, Text: AnsiString); +procedure TPngObject.AddtEXt(const Keyword, Text: String); var TextChunk: TChunkTEXT; begin @@ -5218,7 +5380,7 @@ procedure TPngImage.AddtEXt(const Keyword, Text: AnsiString); end; {Add a text chunk} -procedure TPngImage.AddzTXt(const Keyword, Text: AnsiString); +procedure TPngObject.AddzTXt(const Keyword, Text: String); var TextChunk: TChunkzTXt; begin @@ -5228,7 +5390,7 @@ procedure TPngImage.AddzTXt(const Keyword, Text: AnsiString); end; {Removes the image transparency} -procedure TPngImage.RemoveTransparency; +procedure TPngObject.RemoveTransparency; var TRNS: TChunkTRNS; begin @@ -5257,7 +5419,7 @@ procedure TPngImage.RemoveTransparency; end; {Generates alpha information} -procedure TPngImage.CreateAlpha; +procedure TPngObject.CreateAlpha; var TRNS: TChunkTRNS; begin @@ -5299,7 +5461,7 @@ procedure TPngImage.CreateAlpha; end; {Returns transparent color} -function TPngImage.GetTransparentColor: TColor; +function TPngObject.GetTransparentColor: TColor; var TRNS: TChunkTRNS; begin @@ -5310,7 +5472,7 @@ function TPngImage.GetTransparentColor: TColor; end; {$OPTIMIZATION OFF} -procedure TPngImage.SetTransparentColor(const Value: TColor); +procedure TPngObject.SetTransparentColor(const Value: TColor); var TRNS: TChunkTRNS; begin @@ -5334,13 +5496,13 @@ procedure TPngImage.SetTransparentColor(const Value: TColor); end; {Returns if header is present} -function TPngImage.HeaderPresent: Boolean; +function TPngObject.HeaderPresent: Boolean; begin Result := ((Chunks.Count <> 0) and (Chunks.Item[0] is TChunkIHDR)) end; {Returns pixel for png using palette and grayscale} -function GetByteArrayPixel(const png: TPngImage; const X, Y: Integer): TColor; +function GetByteArrayPixel(const png: TPngObject; const X, Y: Integer): TColor; var ByteData: Byte; DataDepth: Byte; @@ -5386,7 +5548,7 @@ function ColorToRGB(const Color: TColor): COLORREF; {$ENDIF} {Sets a pixel for grayscale and palette pngs} -procedure SetByteArrayPixel(const png: TPngImage; const X, Y: Integer; +procedure SetByteArrayPixel(const png: TPngObject; const X, Y: Integer; const Value: TColor); const ClearFlag: Array[1..8] of Integer = (1, 3, 0, 15, 0, 0, 0, $FF); @@ -5416,7 +5578,7 @@ procedure SetByteArrayPixel(const png: TPngImage; const X, Y: Integer; end; {Returns pixel when png uses RGB} -function GetRGBLinePixel(const png: TPngImage; +function GetRGBLinePixel(const png: TPngObject; const X, Y: Integer): TColor; begin with pRGBLine(png.Scanline[Y])^[X] do @@ -5424,7 +5586,7 @@ function GetRGBLinePixel(const png: TPngImage; end; {Sets pixel when png uses RGB} -procedure SetRGBLinePixel(const png: TPngImage; +procedure SetRGBLinePixel(const png: TPngObject; const X, Y: Integer; Value: TColor); begin with pRGBLine(png.Scanline[Y])^[X] do @@ -5436,7 +5598,7 @@ procedure SetRGBLinePixel(const png: TPngImage; end; {Returns pixel when png uses grayscale} -function GetGrayLinePixel(const png: TPngImage; +function GetGrayLinePixel(const png: TPngObject; const X, Y: Integer): TColor; var B: Byte; @@ -5446,14 +5608,14 @@ function GetGrayLinePixel(const png: TPngImage; end; {Sets pixel when png uses grayscale} -procedure SetGrayLinePixel(const png: TPngImage; +procedure SetGrayLinePixel(const png: TPngObject; const X, Y: Integer; Value: TColor); begin PByteArray(png.Scanline[Y])^[X] := GetRValue(Value); end; {Resizes the PNG image} -procedure TPngImage.Resize(const CX, CY: Integer); +procedure TPngObject.Resize(const CX, CY: Integer); function Min(const A, B: Integer): Integer; begin if A < B then Result := A else Result := B; @@ -5536,7 +5698,7 @@ procedure TPngImage.Resize(const CX, CY: Integer); end; {Sets a pixel} -procedure TPngImage.SetPixels(const X, Y: Integer; const Value: TColor); +procedure TPngObject.SetPixels(const X, Y: Integer; const Value: TColor); begin if ((X >= 0) and (X <= Width - 1)) and ((Y >= 0) and (Y <= Height - 1)) then @@ -5553,7 +5715,7 @@ procedure TPngImage.SetPixels(const X, Y: Integer; const Value: TColor); {Returns a pixel} -function TPngImage.GetPixels(const X, Y: Integer): TColor; +function TPngObject.GetPixels(const X, Y: Integer): TColor; begin if ((X >= 0) and (X <= Width - 1)) and ((Y >= 0) and (Y <= Height - 1)) then @@ -5570,7 +5732,7 @@ function TPngImage.GetPixels(const X, Y: Integer): TColor; end; {Returns the image palette} -function TPngImage.GetPalette: HPALETTE; +function TPngObject.GetPalette: HPALETTE; begin Result := Header.ImagePalette; end; @@ -5610,7 +5772,7 @@ function TChunkpHYs.SaveToStream(Stream: TStream): Boolean; Result := inherited SaveToStream(Stream); end; -procedure TPngImage.DoSetPalette(Value: HPALETTE; const UpdateColors: boolean); +procedure TPngObject.DoSetPalette(Value: HPALETTE; const UpdateColors: boolean); begin if (Header.HasPalette) then begin @@ -5629,13 +5791,13 @@ procedure TPngImage.DoSetPalette(Value: HPALETTE; const UpdateColors: boolean); end; {Set palette based on a windows palette handle} -procedure TPngImage.SetPalette(Value: HPALETTE); +procedure TPngObject.SetPalette(Value: HPALETTE); begin DoSetPalette(Value, true); end; {Returns the library version} -function TPngImage.GetLibraryVersion: String; +function TPNGObject.GetLibraryVersion: String; begin Result := LibraryVersion end; @@ -5647,13 +5809,13 @@ initialization crc_table_computed := FALSE; {Register the necessary chunks for png} RegisterCommonChunks; - {Registers TPngImage to use with TPicture} + {Registers TPNGObject to use with TPicture} {$IFDEF UseDelphi}{$IFDEF RegisterGraphic} - TPicture.RegisterFileFormat('PNG', 'Portable Network Graphics', TPngImage); + TPicture.RegisterFileFormat('PNG', 'Portable Network Graphics', TPNGObject); {$ENDIF}{$ENDIF} finalization {$IFDEF UseDelphi}{$IFDEF RegisterGraphic} - TPicture.UnregisterGraphicClass(TPngImage); + TPicture.UnregisterGraphicClass(TPNGObject); {$ENDIF}{$ENDIF} {Free chunk classes} FreeChunkClassList; diff --git a/Source/System/pnglang.pas b/Source/System/pnglang.pas index 305791a..57965d0 100644 --- a/Source/System/pnglang.pas +++ b/Source/System/pnglang.pas @@ -1,13 +1,8 @@ -{*******************************************************} -{ } -{ CodeGear Delphi Visual Component Library } -{ } -{ Copyright (c) 1995-2008 CodeGear } -{ } -{ Original version written by Gustavo Daud } -{ } -{*******************************************************} +{Portable Network Graphics Delphi Language Info (24 July 2002)} +{Feel free to change the text bellow to adapt to your language} +{Also if you have a translation to other languages and want to} +{share it, send me: gubadaud@terra.com.br } unit pnglang; interface @@ -331,7 +326,7 @@ interface 'kodirana z neznano kompresijsko shemo, ki je ne morem prebrati.'; EPNGUnknownInterlaceText = 'Ta "Portable Network Graphics" slika uporablja ' + 'neznano shemo za preliv, ki je ne morem prebrati.'; - EPNGCannotAssignChunkText = 'Košcki morajo biti med seboj kompatibilni za prireditev vrednosti.'; + EPNGCannotAssignChunkText = Košcki morajo biti med seboj kompatibilni za prireditev vrednosti.'; EPNGUnexpectedEndText = 'Ta "Portable Network Graphics" slika je neveljavna, ' + 'ker je bralnik prišel do nepricakovanega konca datoteke.'; EPNGNoImageDataText = 'Ta "Portable Network Graphics" ne vsebuje nobenih ' + diff --git a/Source/System/zlibpas.pas b/Source/System/zlibpas.pas new file mode 100644 index 0000000..f62838f --- /dev/null +++ b/Source/System/zlibpas.pas @@ -0,0 +1,156 @@ +{Portable Network Graphics Delphi ZLIB linking (16 May 2002) } + +{This unit links ZLIB to pngimage unit in order to implement } +{the library. It's now using the new ZLIB version, 1.1.4 } +{Note: The .obj files must be located in the subdirectory \obj} + +unit zlibpas; + +interface + +type + + TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer; + TFree = procedure (AppData, Block: Pointer); + + // Internal structure. Ignore. + TZStreamRec = packed record + next_in: PChar; // next input byte + avail_in: Integer; // number of bytes available at next_in + total_in: Integer; // total nb of input bytes read so far + + next_out: PChar; // next output byte should be put here + avail_out: Integer; // remaining free space at next_out + total_out: Integer; // total nb of bytes output so far + + msg: PChar; // last error message, NULL if no error + internal: Pointer; // not visible by applications + + zalloc: TAlloc; // used to allocate the internal state + zfree: TFree; // used to free the internal state + AppData: Pointer; // private data object passed to zalloc and zfree + + data_type: Integer; // best guess about the data type: ascii or binary + adler: Integer; // adler32 value of the uncompressed data + reserved: Integer; // reserved for future use + end; + +function inflateInit_(var strm: TZStreamRec; version: PChar; + recsize: Integer): Integer; forward; +function inflate(var strm: TZStreamRec; flush: Integer): Integer; forward; +function inflateEnd(var strm: TZStreamRec): Integer; forward; +function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar; + recsize: Integer): Integer; forward; +function deflate(var strm: TZStreamRec; flush: Integer): Integer; forward; +function deflateEnd(var strm: TZStreamRec): Integer; forward; + +const + zlib_version = '1.2.3'; + + +const + Z_NO_FLUSH = 0; + Z_PARTIAL_FLUSH = 1; + Z_SYNC_FLUSH = 2; + Z_FULL_FLUSH = 3; + Z_FINISH = 4; + + Z_OK = 0; + Z_STREAM_END = 1; + Z_NEED_DICT = 2; + Z_ERRNO = (-1); + Z_STREAM_ERROR = (-2); + Z_DATA_ERROR = (-3); + Z_MEM_ERROR = (-4); + Z_BUF_ERROR = (-5); + Z_VERSION_ERROR = (-6); + + Z_NO_COMPRESSION = 0; + Z_BEST_SPEED = 1; + Z_BEST_COMPRESSION = 9; + Z_DEFAULT_COMPRESSION = (-1); + + Z_FILTERED = 1; + Z_HUFFMAN_ONLY = 2; + Z_DEFAULT_STRATEGY = 0; + + Z_BINARY = 0; + Z_ASCII = 1; + Z_UNKNOWN = 2; + + Z_DEFLATED = 8; + + _z_errmsg: array[0..9] of PChar = ( + 'need dictionary', // Z_NEED_DICT (2) + 'stream end', // Z_STREAM_END (1) + '', // Z_OK (0) + 'file error', // Z_ERRNO (-1) + 'stream error', // Z_STREAM_ERROR (-2) + 'data error', // Z_DATA_ERROR (-3) + 'insufficient memory', // Z_MEM_ERROR (-4) + 'buffer error', // Z_BUF_ERROR (-5) + 'incompatible version', // Z_VERSION_ERROR (-6) + '' + ); + +implementation + +{$L obj\adler32.obj} +{$L obj\deflate.obj} +{$L obj\infback.obj} +{$L obj\inffast.obj} +{$L obj\inflate.obj} +{$L obj\inftrees.obj} +{$L obj\trees.obj} +{$L obj\compress.obj} +{$L obj\crc32.obj} + + + +function adler32(adler: LongInt; const buf: PChar; len: Integer): LongInt; external; + +procedure _memset(P: Pointer; B: Byte; count: Integer);cdecl; +begin + FillChar(P^, count, B); +end; + +procedure _memcpy(dest, source: Pointer; count: Integer);cdecl; +begin + Move(source^, dest^, count); +end; + + +// deflate compresses data +function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar; + recsize: Integer): Integer; external; +function deflate(var strm: TZStreamRec; flush: Integer): Integer; external; +function deflateEnd(var strm: TZStreamRec): Integer; external; + +// inflate decompresses data +function inflateInit_(var strm: TZStreamRec; version: PChar; + recsize: Integer): Integer; external; +function inflate(var strm: TZStreamRec; flush: Integer): Integer; external; +function inflateEnd(var strm: TZStreamRec): Integer; external; +function inflateReset(var strm: TZStreamRec): Integer; external; + + +function zcalloc(AppData: Pointer; Items, Size: Integer): Pointer; +begin + GetMem(Result, Items*Size); +end; + +procedure zcfree(AppData, Block: Pointer); +begin + FreeMem(Block); +end; + +end. + + + + + + + + + diff --git a/Source/Variations/varAuger.pas b/Source/Variations/varAuger.pas new file mode 100644 index 0000000..fcb0ed0 --- /dev/null +++ b/Source/Variations/varAuger.pas @@ -0,0 +1,176 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varAuger; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationAuger = class(TBaseVariation) + private + auger_freq, auger_weight, auger_scale, auger_sym: double; + + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationAuger.Prepare; +begin +end; + +procedure TVariationAuger.CalcFunction; +var x, y, s, t, dx, dy: double; +begin + x := FTx^; + y := FTy^; + + s := sin(auger_freq * x); + t := sin(auger_freq * y); + + dx := x + auger_weight * (0.5 * auger_scale * t + abs(x) * t); + dy := y + auger_weight * (0.5 * auger_scale * s + abs(y) * s); + + FPx^ := FPx^ + VVAR * (x + auger_sym * (dx - x)); + FPy^ := FPy^ + VVAR * dy; + FPz^ := FPz^ + VVAR * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationAuger.Create; +begin + auger_freq := 5; auger_weight := 0.5; + auger_scale := 0.1; auger_sym := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationAuger.GetInstance: TBaseVariation; +begin + Result := TVariationAuger.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationAuger.GetName: string; +begin + Result := 'auger'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationAuger.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'auger_freq'; + 1: Result := 'auger_weight'; + 2: Result := 'auger_scale'; + 3: Result := 'auger_sym'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationAuger.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'auger_freq' then begin + auger_freq := Value; + Result := True; + end else if Name = 'auger_weight' then begin + auger_weight := Value; + Result := True; + end else if Name = 'auger_scale' then begin + auger_scale := Value; + Result := True; + end else if Name = 'auger_sym' then begin + auger_sym := Value; + Result := True; + end +end; +function TVariationAuger.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'auger_freq' then begin + auger_freq := 5; + Result := True; + end else if Name = 'auger_weight' then begin + auger_weight := 0.5; + Result := True; + end else if Name = 'auger_scale' then begin + auger_sym := 0.1; + Result := True; + end else if Name = 'auger_sym' then begin + auger_sym := 0; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationAuger.GetNrVariables: integer; +begin + Result := 4 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationAuger.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'auger_freq' then begin + Value := auger_freq; + Result := True; + end else if Name = 'auger_weight' then begin + Value := auger_weight; + Result := True; + end else if Name = 'auger_scale' then begin + Value := auger_scale; + Result := True; + end else if Name = 'auger_sym' then begin + Value := auger_sym; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationAuger), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varBipolar.pas b/Source/Variations/varBipolar.pas new file mode 100644 index 0000000..af70716 --- /dev/null +++ b/Source/Variations/varBipolar.pas @@ -0,0 +1,162 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varBipolar; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationBipolar = class(TBaseVariation) + private + bipolar_shift, v_4, v, s: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationBipolar.Prepare; +begin + v_4 := VVAR * 0.15915494309189533576888376337251; + v := VVAR * 0.636619772367581343075535053490061; + s := -1.57079632679489661923 * (bipolar_shift); +end; + +procedure TVariationBipolar.CalcFunction; +var x2y2, y, t, x2, f, g : double; +begin + x2y2 := sqr(FTx^) + sqr(FTy^); + y := 0.5 * ArcTan2(2.0 * FTy^, x2y2 - 1.0) + (s); + + if (y > 1.57079632679489661923) then + y := -1.57079632679489661923 + fmod(y + 1.57079632679489661923, PI) + else if (y < -1.57079632679489661923) then + y := 1.57079632679489661923 - fmod(1.57079632679489661923 - y, PI); + + t := x2y2 + 1.0; + x2 := 2.0 * FTx^; + + f := t + x2; + g := t - x2; + + if (g = 0) or (f/g <= 0) then + Exit; + + FPx^ := FPx^ + (v_4) * Ln((t+x2) / (t-x2)); + FPy^ := FPy^ + (v) * y; + + FPz^ := FPz^ + vvar * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationBipolar.Create; +begin + bipolar_shift := 0; + v_4 := 0; + v := 0; + s := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationBipolar.GetInstance: TBaseVariation; +begin + Result := TVariationBipolar.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationBipolar.GetName: string; +begin + Result := 'bipolar'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBipolar.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'bipolar_shift'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBipolar.SetVariable(const Name: string; var value: double): boolean; +var temp: double; +begin + Result := False; + if Name = 'bipolar_shift' then begin + temp := frac(0.5 * (value + 1.0)); + value := 2.0 * temp - 1.0; + bipolar_shift := Value; + Result := True; + end +end; +function TVariationBipolar.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'bipolar_shift' then begin + bipolar_shift := 0; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBipolar.GetNrVariables: integer; +begin + Result := 1 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBipolar.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'bipolar_shift' then begin + Value := bipolar_shift; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationBipolar), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varBlurCircle.pas b/Source/Variations/varBlurCircle.pas new file mode 100644 index 0000000..287cd4b --- /dev/null +++ b/Source/Variations/varBlurCircle.pas @@ -0,0 +1,141 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varBlurCircle; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationBlurCircle = class(TBaseVariation) + private + VVAR4_PI: double; + PI_4: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationBlurCircle.Prepare; +begin + VVAR4_PI := VVAR * 4.0 / PI; + PI_4 := PI / 4.0; +end; + +procedure TVariationBlurCircle.CalcFunction; +var + x, y, absx, absy, side, perimeter, r, sina, cosa: double; +begin + x := 2.0 * random - 1.0; + y := 2.0 * random - 1.0; + + absx := x; if absx < 0 then absx := absx * -1.0; + absy := y; if absy < 0 then absy := absy * -1.0; + + if (absx >= absy) then + begin + if (x >= absy) then + perimeter := absx + y + else perimeter := 5.0 * absx - y; + side := absx; + end else + begin + if (y >= absx) then + perimeter := 3.0 * absy - x + else perimeter := 7.0 * absy + x; + side := absy; + end; + + r := VVAR * side; + SinCos(PI_4 * perimeter / side - PI_4, sina, cosa); + + FPx^ := FPx^ + r * cosa; + FPy^ := FPy^ + r * sina; + FPz^ := FPz^ + vvar * FTz^; +end; + + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationBlurCircle.Create; +begin +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationBlurCircle.GetInstance: TBaseVariation; +begin + Result := TVariationBlurCircle.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationBlurCircle.GetName: string; +begin + Result := 'blur_circle'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBlurCircle.GetVariableNameAt(const Index: integer): string; +begin + Result := ''; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBlurCircle.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBlurCircle.GetNrVariables: integer; +begin + Result := 0 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBlurCircle.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationBlurCircle), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varBlurPixelize.pas b/Source/Variations/varBlurPixelize.pas new file mode 100644 index 0000000..c1b29b5 --- /dev/null +++ b/Source/Variations/varBlurPixelize.pas @@ -0,0 +1,153 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varBlurPixelize; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationBlurPixelize = class(TBaseVariation) + private + blur_pixelize_size, blur_pixelize_scale: double; + inv_size, v: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationBlurPixelize.Prepare; +begin + inv_size := 1.0 / blur_pixelize_size; + v := vvar * blur_pixelize_size; +end; + +procedure TVariationBlurPixelize.CalcFunction; +var x, y: double; +begin + x := floor(FTx^*(inv_size)); + y := floor(FTy^*(inv_size)); + + FPx^ := FPx^ + (v) * (x + (blur_pixelize_scale) * (random - 0.5) + 0.5); + FPy^ := FPy^ + (v) * (y + (blur_pixelize_scale) * (random - 0.5) + 0.5); + FPz^ := FPz^ + vvar * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationBlurPixelize.Create; +begin + blur_pixelize_size := 0.1; + blur_pixelize_scale := 1; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationBlurPixelize.GetInstance: TBaseVariation; +begin + Result := TVariationBlurPixelize.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationBlurPixelize.GetName: string; +begin + Result := 'blur_pixelize'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBlurPixelize.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'blur_pixelize_size'; + 1: Result := 'blur_pixelize_scale'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBlurPixelize.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'blur_pixelize_size' then begin + if (value < 1e-6) then value := 1e-6; + blur_pixelize_size := Value; + Result := True; + end else if Name = 'blur_pixelize_scale' then begin + blur_pixelize_scale := Value; + Result := True; + end +end; +function TVariationBlurPixelize.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'blur_pixelize_size' then begin + blur_pixelize_size := 0.1; + Result := True; + end else if Name = 'blur_pixelize_scale' then begin + blur_pixelize_size := 1; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBlurPixelize.GetNrVariables: integer; +begin + Result := 2 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBlurPixelize.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'blur_pixelize_size' then begin + Value := blur_pixelize_size; + Result := True; + end else if Name = 'blur_pixelize_scale' then begin + Value := blur_pixelize_scale; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationBlurPixelize), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varBlurZoom.pas b/Source/Variations/varBlurZoom.pas new file mode 100644 index 0000000..165abd7 --- /dev/null +++ b/Source/Variations/varBlurZoom.pas @@ -0,0 +1,144 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varBlurZoom; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationBlurZoom = class(TBaseVariation) + private + blur_zoom_length, blur_zoom_x, blur_zoom_y: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationBlurZoom.Prepare; +begin +end; + +procedure TVariationBlurZoom.CalcFunction; +var z: double; +begin + + z := 1.0 + blur_zoom_length * random; + FPx^ := FPx^ + vvar * ((FTx^ - blur_zoom_x) * z + blur_zoom_x); + FPy^ := FPy^ + vvar * ((FTy^ - blur_zoom_y) * z - blur_zoom_y); + FPz^ := FPz^ + vvar * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationBlurZoom.Create; +begin + blur_zoom_length := 0; + blur_zoom_x := 0; + blur_zoom_y := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationBlurZoom.GetInstance: TBaseVariation; +begin + Result := TVariationBlurZoom.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationBlurZoom.GetName: string; +begin + Result := 'blur_zoom'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBlurZoom.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'blur_zoom_length'; + 1: Result := 'blur_zoom_x'; + 2: Result := 'blur_zoom_y'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBlurZoom.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'blur_zoom_length' then begin + blur_zoom_length := Value; + Result := True; + end else if Name = 'blur_zoom_x' then begin + blur_zoom_y := Value; + Result := True; + end else if Name = 'blur_zoom_y' then begin + blur_zoom_y := Value; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBlurZoom.GetNrVariables: integer; +begin + Result := 3 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBlurZoom.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'blur_zoom_length' then begin + Value := blur_zoom_length; + Result := True; + end else if Name = 'blur_zoom_x' then begin + Value := blur_zoom_x; + Result := True; + end else if Name = 'blur_zoom_y' then begin + Value := blur_zoom_y; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationBlurZoom), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varBwraps.pas b/Source/Variations/varBwraps.pas new file mode 100644 index 0000000..49ca0c2 --- /dev/null +++ b/Source/Variations/varBwraps.pas @@ -0,0 +1,238 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varBwraps; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationBwraps = class(TBaseVariation) + private + bwraps_cellsize, bwraps_space, bwraps_gain, + bwraps_inner_twist, bwraps_outer_twist, + g2, r2, rfactor: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationBwraps.Prepare; +var + max_bubble, radius: double; +begin + radius := 0.5 * (bwraps_cellsize / (1.0 + sqr(bwraps_space))); + g2 := sqr(bwraps_gain) / (radius + 1e-6) + 1e-6; + max_bubble := g2 * radius; + + if (max_bubble > 2.0) then max_bubble := 1.0 + else max_bubble := max_bubble * (1.0 / (sqr(max_bubble)/4.0 + 1.0)); + + r2 := sqr(radius); + rfactor := radius / max_bubble; +end; + +procedure TVariationBwraps.CalcFunction; +var + Vx, Vy, + Cx, Cy, + Lx, Ly, + r, theta, s, c : double; +begin + Vx := FTx^; + Vy := FTy^; + + if (bwraps_cellsize = 0.0) then + begin + FPx^ := FPx^ + VVAR * FTx^; + FPy^ := FPy^ + VVAR * FTy^; + FPz^ := FPz^ + VVAR * FTz^; + end else + begin + Cx := (floor(Vx / bwraps_cellsize) + 0.5) * bwraps_cellsize; + Cy := (floor(Vy / bwraps_cellsize) + 0.5) * bwraps_cellsize; + + Lx := Vx - Cx; + Ly := Vy - Cy; + + if ((sqr(Lx) + sqr(Ly)) > r2) then + begin + FPx^ := FPx^ + VVAR * FTx^; + FPy^ := FPy^ + VVAR * FTy^; + FPz^ := FPz^ + VVAR * FTz^; + end else + begin + Lx := Lx * g2; + Ly := Ly * g2; + + r := rfactor / ((sqr(Lx) + sqr(Ly)) / 4.0 + 1); + + Lx := Lx * r; + Ly := Ly * r; + + r := (sqr(Lx) + sqr(Ly)) / r2; + theta := bwraps_inner_twist * (1.0 - r) + bwraps_outer_twist * r; + SinCos(theta, s, c); + + Vx := Cx + c * Lx + s * Ly; + Vy := Cy - s * Lx + c * Ly; + + FPx^ := FPx^ + VVAR * Vx; + FPy^ := FPy^ + VVAR * Vy; + FPz^ := FPz^ + VVAR * FTz^; + end; + end; + +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationBwraps.Create; +begin + bwraps_cellsize := 1; + bwraps_space := 0; + bwraps_gain := 1; + bwraps_inner_twist := 0; + bwraps_outer_twist := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationBwraps.GetInstance: TBaseVariation; +begin + Result := TVariationBwraps.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationBwraps.GetName: string; +begin + Result := 'bwraps'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBwraps.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'bwraps_cellsize'; + 1: Result := 'bwraps_space'; + 2: Result := 'bwraps_gain'; + 3: Result := 'bwraps_inner_twist'; + 4: Result := 'bwraps_outer_twist'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBwraps.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'bwraps_cellsize' then begin + bwraps_cellsize := Value; + Result := True; + end else if Name = 'bwraps_space' then begin + bwraps_space := Value; + Result := True; + end else if Name = 'bwraps_gain' then begin + bwraps_gain := Value; + Result := True; + end else if Name = 'bwraps_inner_twist' then begin + bwraps_inner_twist := Value; + Result := True; + end else if Name = 'bwraps_outer_twist' then begin + bwraps_outer_twist := Value; + Result := True; + end +end; +function TVariationBwraps.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'bwraps_cellsize' then begin + bwraps_cellsize := 1; + Result := True; + end else if Name = 'bwraps_space' then begin + bwraps_space := 0; + Result := True; + end else if Name = 'bwraps_gain' then begin + bwraps_gain := 1; + Result := True; + end else if Name = 'bwraps_inner_twist' then begin + bwraps_inner_twist := 0; + Result := True; + end else if Name = 'bwraps_outer_twist' then begin + bwraps_outer_twist := 0; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBwraps.GetNrVariables: integer; +begin + Result := 5 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationBwraps.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'bwraps_cellsize' then begin + if Value = 0 then Value := 1e-6; + Value := bwraps_cellsize; + Result := True; + end else if Name = 'bwraps_space' then begin + Value := bwraps_space; + Result := True; + end else if Name = 'bwraps_gain' then begin + Value := bwraps_gain; + Result := True; + end else if Name = 'bwraps_inner_twist' then begin + Value := bwraps_inner_twist; + Result := True; + end else if Name = 'bwraps_outer_twist' then begin + Value := bwraps_outer_twist; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationBwraps), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varCrop.pas b/Source/Variations/varCrop.pas new file mode 100644 index 0000000..66cf7b1 --- /dev/null +++ b/Source/Variations/varCrop.pas @@ -0,0 +1,232 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varCrop; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationCrop = class(TBaseVariation) + const + n_x0 : string = 'crop_left'; + n_y0 : string = 'crop_top'; + n_x1 : string = 'crop_right'; + n_y1 : string = 'crop_bottom'; + n_s : string = 'crop_scatter_area'; + n_z : string = 'crop_zero'; + n : string = 'crop'; + + private + x0, y0, x1, y1, s, w, h: double; + _x0, _y0, _x1, _y1: double; + z: integer; + + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationCrop.Prepare; +begin + if (x0 < x1) then begin + _x0 := x0; + _x1 := x1; + end else begin + _x0 := x1; + _x1 := x0; + end; + + if (y0 < y1) then begin + _y0 := y0; + _y1 := y1; + end else begin + _y0 := y1; + _y1 := y0; + end; + + w := (_x1 - _x0) * 0.5 * s; + h := (_y1 - _y0) * 0.5 * s; +end; + +procedure TVariationCrop.CalcFunction; +var x, y: double; +begin + x := FTx^; + y := FTy^; + + if ((x < _x0) or (x > _x1) or (y < _y0) or (y > _y1)) and (z <> 0) then begin + x := 0; y := 0; + end else begin + if x < _x0 then x := _x0 + random * w + else if x > _x1 then x := _x1 - random * w; + if y < _y0 then y := _y0 + random * h + else if y > _y1 then y := _y1 - random * h; + end; + + FPx^ := FPx^ + VVAR * x; + FPy^ := FPy^ + VVAR * y; + FPz^ := FPz^ + VVAR * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationCrop.Create; +begin + x0 := -1; x1 := 1; + y0 := -1; y1 := 1; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationCrop.GetInstance: TBaseVariation; +begin + Result := TVariationCrop.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationCrop.GetName: string; +begin + Result := n; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationCrop.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := n_x0; + 1: Result := n_y0; + 2: Result := n_x1; + 3: Result := n_y1; + 4: Result := n_s; + 5: Result := n_z; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationCrop.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = n_x0 then begin + x0 := Value; + Result := True; + end else if Name = n_y0 then begin + y0 := Value; + Result := True; + end else if Name = n_x1 then begin + x1 := Value; + Result := True; + end else if Name = n_y1 then begin + y1 := Value; + Result := True; + end else if Name = n_s then begin + if (Value < -1) then Value := -1; + if (Value > 1) then Value := 1; + s := Value; + Result := True; + end else if Name = n_z then begin + if (Value > 1) then Value := 1; + if (Value < 0) then Value := 0; + z := Round(Value); + Result := True; + end +end; +function TVariationCrop.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = n_x0 then begin + x0 := -1; + Result := True; + end else if Name = n_y0 then begin + y0 := -1; + Result := True; + end else if Name = n_x1 then begin + x1 := 1; + Result := True; + end else if Name = n_y1 then begin + y1 := 1; + Result := True; + end else if Name = n_s then begin + s := 0; + Result := True; + end else if Name = n_z then begin + z := 0; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationCrop.GetNrVariables: integer; +begin + Result := 6 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationCrop.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = n_x0 then begin + Value := x0; + Result := True; + end else if Name = n_y0 then begin + Value := y0; + Result := True; + end else if Name = n_x1 then begin + Value := x1; + Result := True; + end else if Name = n_y1 then begin + Value := y1; + Result := True; + end else if Name = n_s then begin + Value := s; + Result := True; + end else if Name = n_z then begin + Value := z; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationCrop), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varCross.pas b/Source/Variations/varCross.pas new file mode 100644 index 0000000..f335ea4 --- /dev/null +++ b/Source/Variations/varCross.pas @@ -0,0 +1,111 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varCross; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationCross = class(TBaseVariation) + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationCross.CalcFunction; +var + r: double; +begin + r := Abs((FTx^ - FTy^) * (FTx^ + FTy^) + 1e-6); + if (r < 0) then r := r * -1.0; + r := VVAR / r; + + FPx^ := FPx^ + FTx^ * r; + FPy^ := FPy^ + FTy^ * r; + FPz^ := FPz^ + vvar * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationCross.Create; +begin +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationCross.GetInstance: TBaseVariation; +begin + Result := TVariationCross.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationCross.GetName: string; +begin + Result := 'cross'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationCross.GetVariableNameAt(const Index: integer): string; +begin + Result := ''; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationCross.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationCross.GetNrVariables: integer; +begin + Result := 0 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationCross.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationCross), true, false); +end. diff --git a/Source/Variations/varCurl.pas b/Source/Variations/varCurl.pas index 94e3ee4..c392833 100644 --- a/Source/Variations/varCurl.pas +++ b/Source/Variations/varCurl.pas @@ -34,7 +34,7 @@ interface var_c1_name='curl_c1'; var_c2_name='curl_c2'; -{$define _ASM_} +//{$define _ASM_} // z // The formula is: f(z) = ------------------- , where z = complex (x + i*y) @@ -116,7 +116,6 @@ procedure TVariationCurl.GetCalcFunction(var f: TCalcFunction); /////////////////////////////////////////////////////////////////////////////// procedure TVariationCurl.CalcFunction; -{$ifndef _ASM_} var r: double; re, im: double; @@ -128,58 +127,10 @@ procedure TVariationCurl.CalcFunction; FPx^ := FPx^ + (FTx^*re + FTy^*im) * r; FPy^ := FPy^ + (FTy^*re - FTx^*im) * r; -{$else} -asm - mov edx, [eax + FTx] - fld qword ptr [edx + 8] // FTy - fld qword ptr [edx] // FTx - fld st(1) - fmul st, st(1) - fmul qword ptr [eax + c2x2] - fld st(2) - fmul qword ptr [eax + c1] - faddp - fld st(2) - fmul st, st - fld st(2) - fmul st, st - fsubrp - fmul qword ptr [eax + c2] - fld1 - faddp - fld st(2) - fmul qword ptr [eax + c1] - faddp - - fld st(1) - fmul st, st - fld st(1) - fmul st, st - faddp - fdivr qword ptr [eax + vvar] - - fld st(3) - fmul st, st(2) - fld st(5) - fmul st, st(4) - faddp - fmul st, st(1) - fadd qword ptr [edx + 16] // FPx - fstp qword ptr [edx + 16] - - fxch st(4) - fmulp - fxch st(2) - fmulp - fsubp - fmulp - fadd qword ptr [edx + 24] // FPy - fstp qword ptr [edx + 24] -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; procedure TVariationCurl.CalcZeroC2; -{$ifndef _ASM_} var r: double; re, im: double; @@ -191,47 +142,10 @@ procedure TVariationCurl.CalcZeroC2; FPx^ := FPx^ + (FTx^*re + FTy^*im) * r; FPy^ := FPy^ + (FTy^*re - FTx^*im) * r; -{$else} -asm - mov edx, [eax + FTx] - fld qword ptr [edx + 8] // FTy - fld qword ptr [edx] // FTx - fld st(1) - fld qword ptr [eax + c1] - fmul st(1), st - fmul st, st(2) - fld1 - faddp - - fld st(1) - fmul st, st - fld st(1) - fmul st, st - faddp - fdivr qword ptr [eax + vvar] - - fld st(3) - fmul st, st(2) - fld st(5) - fmul st, st(4) - faddp - fmul st, st(1) - fadd qword ptr [edx + 16] // FPx - fstp qword ptr [edx + 16] - - fxch st(4) - fmulp - fxch st(2) - fmulp - fsubp - fmulp - fadd qword ptr [edx + 24] // FPy - fstp qword ptr [edx + 24] -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; procedure TVariationCurl.CalcZeroC1; -{$ifndef _ASM_} var r: double; re, im: double; @@ -243,69 +157,16 @@ procedure TVariationCurl.CalcZeroC1; FPx^ := FPx^ + (FTx^*re + FTy^*im) * r; FPy^ := FPy^ + (FTy^*re - FTx^*im) * r; -{$else} -asm - mov edx, [eax + FTx] - fld qword ptr [edx + 8] // FTy - fld qword ptr [edx] // FTx - fld st(1) - fmul st, st(1) - fmul qword ptr [eax + c2x2] - fld st(2) - fmul st, st - fld st(2) - fmul st, st - fsubrp - fmul qword ptr [eax + c2] - fld1 - faddp - - fld st(1) - fmul st, st - fld st(1) - fmul st, st - faddp - fdivr qword ptr [eax + vvar] - - fld st(3) - fmul st, st(2) - fld st(5) - fmul st, st(4) - faddp - fmul st, st(1) - fadd qword ptr [edx + 16] // FPx - fstp qword ptr [edx + 16] - - fxch st(4) - fmulp - fxch st(2) - fmulp - fsubp - fmulp - fadd qword ptr [edx + 24] // FPy - fstp qword ptr [edx + 24] -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; procedure TVariationCurl.CalcZeroC2C1; -{$ifndef _ASM_} var r: double; begin FPx^ := FPx^ + vvar*FTx^; FPy^ := FPy^ + vvar*FTy^; -{$else} -asm - mov edx, [eax + FTx] - fld qword ptr [edx + 8] // FTy - fld qword ptr [eax + vvar] - fmul st(1), st - fmul qword ptr [edx] // FTx - fadd qword ptr [edx + 16] // FPx - fstp qword ptr [edx + 16] - fadd qword ptr [edx + 24] // FPy - fstp qword ptr [edx + 24] -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; /////////////////////////////////////////////////////////////////////////////// @@ -380,5 +241,5 @@ function TVariationCurl.GetVariable(const Name: string; var value: double): bool /////////////////////////////////////////////////////////////////////////////// initialization - RegisterVariation(TVariationClassLoader.Create(TVariationCurl), false, false); + RegisterVariation(TVariationClassLoader.Create(TVariationCurl), true, false); end. diff --git a/Source/Variations/varElliptic.pas b/Source/Variations/varElliptic.pas new file mode 100644 index 0000000..aa69a5d --- /dev/null +++ b/Source/Variations/varElliptic.pas @@ -0,0 +1,131 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varElliptic; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationElliptic = class(TBaseVariation) + private + v: double; + + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + + + procedure CalcFunction; override; + procedure Prepare; override; + end; + +implementation + +uses + Math; + + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationElliptic.Prepare; +begin + v := VVAR / (PI / 2.0) +end; +procedure TVariationElliptic.CalcFunction; +function sqrt_safe(x: double): double; + begin + if x < 0.0 then Result := 0.0 + else Result := sqrt(x); + end; +var + a, b, tmp, x2, xmax: double; +begin + tmp := sqr(FTy^) + sqr(FTx^) + 1.0; + x2 := 2.0 * FTx^; + xmax := 0.5 * (sqrt(tmp + x2) + sqrt(tmp - x2)); + + a := FTx^ / xmax; + b := sqrt_safe(1.0 - sqr(a)); + + FPz^ := FPz^ + vvar * FTz^; + FPx^ := FPx^ + v * ArcTan2(a, b); + + if (FTy^ > 0) then FPy^ := FPy^ + v * Ln(xmax + sqrt_safe(xmax - 1.0)) + else FPy^ := FPy^ - v * Ln(xmax + sqrt_safe(xmax - 1.0)) +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationElliptic.Create; +begin +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationElliptic.GetInstance: TBaseVariation; +begin + Result := TVariationElliptic.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationElliptic.GetName: string; +begin + Result := 'elliptic'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationElliptic.GetVariableNameAt(const Index: integer): string; +begin + Result := ''; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationElliptic.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationElliptic.GetNrVariables: integer; +begin + Result := 0 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationElliptic.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationElliptic), true, false); +end. diff --git a/Source/Variations/varEpispiral.pas b/Source/Variations/varEpispiral.pas new file mode 100644 index 0000000..cc6cb96 --- /dev/null +++ b/Source/Variations/varEpispiral.pas @@ -0,0 +1,159 @@ +unit varEpispiral; // <-- JK Changed unit name to avoid clobbering original +//by Joel Faber (adapted for plugin example by Jed Kelsey (JK) +interface + +uses + BaseVariation, XFormMan; // <-- JK Removed some (unnecessary?) units + +const + EPS: double = 1E-6; +type + TVariationEpispiral = class(TBaseVariation) + private + n, thickness, holes : double; + + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +// TVariationEpispiral + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationEpispiral.Create; +begin + n := 6.0; + thickness := 0.0; + holes := 1.0; +end; + +procedure TVariationEpispiral.Prepare; +begin //calculate constants + // nothing for now +end; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationEpispiral.CalcFunction; +var + t, theta : double; +begin + theta := arctan2(FTy^, FTx^); + + t := (random*thickness)*(1/cos(n*theta)) - holes; + + + if (abs(t) = 0) then + begin + FPx^ := FPx^; + FPy^ := FPy^; + end + else + begin + FPx^ := FPx^ + vvar*t*cos(theta); + FPy^ := FPy^ + vvar*t*sin(theta); + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationEpispiral.GetInstance: TBaseVariation; +begin + Result := TVariationEpispiral.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationEpispiral.GetName: string; +begin + Result := 'epispiral'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationEpispiral.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'epispiral_n'; + 1: Result := 'epispiral_thickness'; + 2: Result := 'epispiral_holes'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationEpispiral.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'epispiral_n' then begin + n := Value; + Result := True; + end else if Name = 'epispiral_thickness' then begin + thickness := Value; + Result := True; + end + else if Name = 'epispiral_holes' then begin + holes := Value; + Result := True; + end +end; + +function TVariationEpispiral.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'epispiral_n' then begin + n := 6.0; + Result := True; + end else if Name = 'epispiral_thickness' then begin + thickness := 0.0; + Result := True; + end + else if Name = 'epispiral_holes' then begin + holes := 0.0; + Result := True; + end +end; + + +/////////////////////////////////////////////////////////////////////////////// +function TVariationEpispiral.GetNrVariables: integer; +begin + Result := 3; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationEpispiral.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'epispiral_n' then begin + Value := n; + Result := True; + end else if Name = 'epispiral_thickness' then begin + Value := thickness; + Result := True; + end + else if Name = 'epispiral_holes' then begin + Value := holes; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationEpispiral), true, false); // <-- JK Plugin manager does this +end. + diff --git a/Source/Variations/varEscher.pas b/Source/Variations/varEscher.pas new file mode 100644 index 0000000..b79ee0c --- /dev/null +++ b/Source/Variations/varEscher.pas @@ -0,0 +1,147 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varEscher; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationEscher = class(TBaseVariation) + private + escher_beta, c, d: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationEscher.Prepare; +begin + sincos(escher_beta, d, c); + c := 0.5 * (1.0 + c); + d := 0.5 * d; +end; + +procedure TVariationEscher.CalcFunction; +var sn, cs, a, lnr, m : double; +begin + a := arctan2(FTy^, FTx^); // Angular polar dimension + lnr := 0.5 * ln(FTx^*FTx^ + FTy^*FTy^); // Natural logarithm of the radial polar dimension. + + m := VVAR * exp(c * lnr - d * a); + + sincos(c * a + d * lnr, sn, cs); + + FPx^ := FPx^ + m * cs; + FPy^ := FPy^ + m * sn; + + FPz^ := FPz^ + vvar * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationEscher.Create; +begin + escher_beta := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationEscher.GetInstance: TBaseVariation; +begin + Result := TVariationEscher.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationEscher.GetName: string; +begin + Result := 'escher'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationEscher.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'escher_beta'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationEscher.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'escher_beta' then begin + value := frac((value + PI) / (2 * PI)) * 2 * PI - PI; + escher_beta := Value; + Result := True; + end +end; +function TVariationEscher.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'escher_beta' then begin + escher_beta := 0; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationEscher.GetNrVariables: integer; +begin + Result := 1 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationEscher.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'escher_beta' then begin + Value := escher_beta; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationEscher), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varFalloff2.pas b/Source/Variations/varFalloff2.pas new file mode 100644 index 0000000..0c92e9e --- /dev/null +++ b/Source/Variations/varFalloff2.pas @@ -0,0 +1,348 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varFalloff2; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationFalloff2 = class(TBaseVariation) + const + n_scatter : string = 'falloff2_scatter'; + n_mindist : string = 'falloff2_mindist'; + n_mul_x : string = 'falloff2_mul_x'; + n_mul_y : string = 'falloff2_mul_y'; + n_mul_z : string = 'falloff2_mul_z'; + n_mul_c : string = 'falloff2_mul_c'; + n_x0 : string = 'falloff2_x0'; + n_y0 : string = 'falloff2_y0'; + n_z0 : string = 'falloff2_z0'; + n_invert : string = 'falloff2_invert'; + n_blurtype : string = 'falloff2_type'; + + private + rmax: double; + x0, y0, z0: double; + scatter, mindist: double; + invert, blurtype: integer; + mul_x, mul_y, mul_z, mul_c: double; + + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + procedure CalcFunctionRadial; + procedure CalcFunctionGaussian; + procedure GetCalcFunction(var f: TCalcFunction); override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationFalloff2.Prepare; +begin + rmax := 0.04 * scatter; +end; + +procedure TVariationFalloff2.GetCalcFunction(var f: TCalcFunction); +begin + if blurtype = 1 then f := CalcFunctionRadial + else if blurtype = 2 then f := CalcFunctionGaussian + else f := CalcFunction; +end; +procedure TVariationFalloff2.CalcFunction; +var + in_x, in_y, in_z, d: double; +begin + in_x := FTx^; + in_y := FTy^; + in_z := FTz^; + + d := sqrt(sqr(in_x - x0) + sqr(in_y - y0) + sqr(in_z - z0)); + if (invert <> 0) then d := 1 - d; if (d < 0) then d := 0; + d := (d - mindist) * rmax; if (d < 0) then d := 0; + + FPx^ := FPx^ + VVAR * (in_x + mul_x * random * d); + FPy^ := FPy^ + VVAR * (in_y + mul_y * random * d); + FPz^ := FPz^ + VVAR * (in_z + mul_z * random * d); + color^ := Abs(Frac(color^ + mul_c * random * d)); +end; +procedure TVariationFalloff2.CalcFunctionRadial; +var + in_x, in_y, in_z, d, r_in: double; + sigma, phi, r, sins, coss, sinp, cosp: double; +begin + in_x := FTx^; + in_y := FTy^; + in_z := FTz^; + + r_in := sqrt(sqr(in_x) + sqr(in_y) + sqr(in_z)) + 1e-6; + d := sqrt(sqr(in_x - x0) + sqr(in_y - y0) + sqr(in_z - z0)); + if (invert <> 0) then d := 1 - d; if (d < 0) then d := 0; + d := (d - mindist) * rmax; if (d < 0) then d := 0; + + sigma := ArcSin(in_z / r_in) + mul_z * random * d; + phi := ArcTan2(in_y, in_x) + mul_y * random * d; + r := r_in + mul_x * random * d; + + SinCos(sigma, sins, coss); + SinCos(phi, sinp, cosp); + + FPx^ := FPx^ + VVAR * (r * coss * cosp); + FPy^ := FPy^ + VVAR * (r * coss * sinp); + FPz^ := FPz^ + VVAR * (sins); + color^ := Abs(Frac(color^ + mul_c * random * d)); +end; +procedure TVariationFalloff2.CalcFunctionGaussian; +var + in_x, in_y, in_z, d: double; + sigma, phi, r, sins, coss, sinp, cosp: double; +begin + in_x := FTx^; + in_y := FTy^; + in_z := FTz^; + + d := sqrt(sqr(in_x - x0) + sqr(in_y - y0) + sqr(in_z - z0)); + if (invert <> 0) then d := 1 - d; if (d < 0) then d := 0; + d := (d - mindist) * rmax; if (d < 0) then d := 0; + + sigma := d * random * 2 * PI; + phi := d * random * PI; + r := d * random; + + SinCos(sigma, sins, coss); + SinCos(phi, sinp, cosp); + + FPx^ := FPx^ + VVAR * (in_x + mul_x * r * coss * cosp); + FPy^ := FPy^ + VVAR * (in_y + mul_y * r * coss * sinp); + FPz^ := FPz^ + VVAR * (in_z + mul_z * r * sins); + color^ := Abs(Frac(color^ + mul_c * random * d)); +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationFalloff2.Create; +begin + scatter := 1; + mindist := 0.5; + mul_x := 1; + mul_y := 1; + mul_z := 0; + mul_c := 0; + x0 := 0; + y0 := 0; + z0 := 0; + invert := 0; + blurtype := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationFalloff2.GetInstance: TBaseVariation; +begin + Result := TVariationFalloff2.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationFalloff2.GetName: string; +begin + Result := 'falloff2'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationFalloff2.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := n_scatter; + 1: Result := n_mindist; + 2: Result := n_mul_x; + 3: Result := n_mul_y; + 4: Result := n_mul_z; + 5: Result := n_mul_c; + 6: Result := n_x0; + 7: Result := n_y0; + 8: Result := n_z0; + 9: Result := n_invert; + 10: Result := n_blurtype; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationFalloff2.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = n_scatter then begin + if Value < 1e-6 then Value := 1e-6; + scatter := Value; + Result := True; + end else if Name = n_mindist then begin + if Value < 0 then Value := 0; + mindist := Value; + Result := True; + end else if Name = n_mul_x then begin + if Value < 0 then Value := 0 + else if Value > 1 then Value := 1; + mul_x := Value; + Result := True; + end else if Name = n_mul_y then begin + if Value < 0 then Value := 0 + else if Value > 1 then Value := 1; + mul_y := Value; + Result := True; + end else if Name = n_mul_z then begin + if Value < 0 then Value := 0 + else if Value > 1 then Value := 1; + mul_z := Value; + Result := True; + end else if Name = n_mul_c then begin + if Value < 0 then Value := 0 + else if Value > 1 then Value := 1; + mul_c := Value; + Result := True; + end else if Name = n_x0 then begin + x0 := Value; + Result := True; + end else if Name = n_y0 then begin + y0 := Value; + Result := True; + end else if Name = n_z0 then begin + z0 := Value; + Result := True; + end else if Name = n_invert then begin + if (Value > 1) then Value := 1; + if (Value < 0) then Value := 0; + invert := Round(Value); + Result := True; + end else if Name = n_blurtype then begin + if (Value > 2) then Value := 2; + if (Value < 0) then Value := 0; + blurtype := Round(Value); + Result := True; + end +end; +function TVariationFalloff2.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = n_scatter then begin + scatter := 1; + Result := True; + end else if Name = n_mindist then begin + mindist := 0.5; + Result := True; + end else if Name = n_mul_x then begin + mul_x := 1; + Result := True; + end else if Name = n_mul_y then begin + mul_y := 1; + Result := True; + end else if Name = n_mul_z then begin + mul_z := 0; + Result := True; + end else if Name = n_mul_c then begin + mul_c := 0; + Result := True; + end else if Name = n_x0 then begin + x0 := 0; + Result := True; + end else if Name = n_y0 then begin + y0 := 0; + Result := True; + end else if Name = n_z0 then begin + z0 := 0; + Result := True; + end else if Name = n_invert then begin + invert := 0; + Result := True; + end else if Name = n_blurtype then begin + blurtype := 0; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationFalloff2.GetNrVariables: integer; +begin + Result := 11 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationFalloff2.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = n_scatter then begin + Value := scatter; + Result := True; + end else if Name = n_mindist then begin + Value := mindist; + Result := True; + end else if Name = n_mul_x then begin + Value := mul_x; + Result := True; + end else if Name = n_mul_y then begin + Value := mul_y; + Result := True; + end else if Name = n_mul_z then begin + Value := mul_z; + Result := True; + end else if Name = n_mul_c then begin + Value := mul_c; + Result := True; + end else if Name = n_x0 then begin + Value := x0; + Result := True; + end else if Name = n_y0 then begin + Value := y0; + Result := True; + end else if Name = n_z0 then begin + Value := z0; + Result := True; + end else if Name = n_invert then begin + Value := invert; + Result := True; + end else if Name = n_blurtype then begin + Value := blurtype; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationFalloff2), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varFan2.pas b/Source/Variations/varFan2.pas index 0ccb134..3236cbd 100644 --- a/Source/Variations/varFan2.pas +++ b/Source/Variations/varFan2.pas @@ -97,16 +97,11 @@ procedure TVariationFan2.CalcFunction; a := Angle - dx2 else a := Angle + dx2; - asm // SinCos(a, sinr, cosr); - FLD qword ptr [a] - FSINCOS - FSTP qword ptr [sinr] - FSTP qword ptr [cosr] - FWAIT - end; + SinCos(a, sinr, cosr); r := vvar * sqrt(sqr(FTx^) + sqr(FTy^)); FPx^ := FPx^ + r * cosr; FPy^ := FPy^ + r * sinr; + FPz^ := FPz^ + vvar * FTz^; end; /////////////////////////////////////////////////////////////////////////////// @@ -173,5 +168,5 @@ function TVariationFan2.GetVariable(const Name: string; var value: double): bool /////////////////////////////////////////////////////////////////////////////// initialization - RegisterVariation(TVariationClassLoader.Create(TVariationFan2), false, false); + RegisterVariation(TVariationClassLoader.Create(TVariationFan2), true, false); end. diff --git a/Source/Variations/varFoci.pas b/Source/Variations/varFoci.pas new file mode 100644 index 0000000..7758229 --- /dev/null +++ b/Source/Variations/varFoci.pas @@ -0,0 +1,118 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varFoci; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationFoci = class(TBaseVariation) + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + + + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationFoci.CalcFunction; +var + expx, expnx, siny, cosy, tmp: double; +begin + expx := exp(FTx^) * 0.5; + expnx := 0.25 / expx; + sincos(FTy^, siny, cosy); + + tmp := ( expx + expnx - cosy ); + if (tmp = 0) then tmp := 1e-6; + tmp := VVAR / tmp; + + FPx^ := FPx^ + (expx - expnx) * tmp; + FPy^ := FPy^ + siny * tmp; + + FPz^ := FPz^ + vvar * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationFoci.Create; +begin +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationFoci.GetInstance: TBaseVariation; +begin + Result := TVariationFoci.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationFoci.GetName: string; +begin + Result := 'foci'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationFoci.GetVariableNameAt(const Index: integer): string; +begin + Result := ''; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationFoci.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationFoci.GetNrVariables: integer; +begin + Result := 0 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationFoci.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationFoci), true, false); +end. diff --git a/Source/Variations/varGenericPlugin.pas b/Source/Variations/varGenericPlugin.pas index f8ccbef..d19f7fc 100644 --- a/Source/Variations/varGenericPlugin.pas +++ b/Source/Variations/varGenericPlugin.pas @@ -52,9 +52,9 @@ TPluginData = record PluginHandle: THandle; PluginClass: TPluginVariationClass; - PluginVarGetName: function: PChar; cdecl; + PluginVarGetName: function: PAnsiChar; cdecl; PluginVarGetNrVariables: function: Integer; cdecl; - PluginVarGetVariableNameAt: function(const Index: integer): PChar; cdecl; + PluginVarGetVariableNameAt: function(const Index: integer): PAnsiChar; cdecl; PluginVarCreate: function: Pointer; cdecl; PluginVarDestroy: function(var MyVariation: Pointer): LongBool; cdecl; @@ -63,9 +63,9 @@ TPluginData = record PluginVarInitDC: function(MyVariation, FPx, FPy, FPz, FTx, FTy, FTz, color: Pointer; vvar, a, b, c, d, e, f: double): LongBool; cdecl; PluginVarPrepare: function(MyVariation: Pointer): LongBool; cdecl; PluginVarCalc: function(MyVariation: Pointer): LongBool; cdecl; - PluginVarGetVariable: function(MyVariation: Pointer; const Name: PChar; var value: double): LongBool; cdecl; - PluginVarSetVariable: function(MyVariation: Pointer; const Name: PChar; var value: double): LongBool; cdecl; - PluginVarResetVariable:function(MyVariation: Pointer; const Name: PChar) : LongBool; cdecl; + PluginVarGetVariable: function(MyVariation: Pointer; const Name: PAnsiChar; var value: double): LongBool; cdecl; + PluginVarSetVariable: function(MyVariation: Pointer; const Name: PAnsiChar; var value: double): LongBool; cdecl; + PluginVarResetVariable:function(MyVariation: Pointer; const Name: PAnsiChar) : LongBool; cdecl; end; PPluginData = ^TPluginData; @@ -75,7 +75,6 @@ TPluginVariation = class(TBaseVariation) private PluginData : TPluginData; MyVariation : Pointer; - public constructor Create(varData : TPluginData); destructor Destroy; override; @@ -116,7 +115,9 @@ implementation uses Windows, //LoadLibrary - Math; + Math, + Global, + Registry; { TPluginVariation } @@ -134,7 +135,7 @@ destructor TVariationPluginLoader.Destroy; function TVariationPluginLoader.GetName : string; begin - Result := PluginData.PluginVarGetName; + Result := String(PluginData.PluginVarGetName); end; function TVariationPluginLoader.GetInstance: TBaseVariation; @@ -149,7 +150,7 @@ function TVariationPluginLoader.GetNrVariables: integer; function TVariationPluginLoader.GetVariableNameAt(const Index: integer): string; begin - Result := PluginData.PluginVarGetVariableNameAt(Index); + Result := String(PluginData.PluginVarGetVariableNameAt(Index)); end; /////////////////////////////////////////////////////////////////////////////// @@ -208,19 +209,19 @@ function TPluginVariation.GetNrVariables: integer; /////////////////////////////////////////////////////////////////////////////// function TPluginVariation.GetVariableNameAt(const Index: integer): string; begin - Result := PluginData.PluginVarGetVariableNameAt(Index); + Result := String(PluginData.PluginVarGetVariableNameAt(Index)); end; /////////////////////////////////////////////////////////////////////////////// function TPluginVariation.SetVariable(const Name: string; var value: double): boolean; begin - Result := PluginData.PluginVarSetVariable(MyVariation,PChar(Name),value); + Result := PluginData.PluginVarSetVariable(MyVariation,PAnsiChar(AnsiString(Name)),value); end; /////////////////////////////////////////////////////////////////////////////// function TPluginVariation.GetVariable(const Name: string; var value: double): boolean; begin - Result := PluginData.PluginVarGetVariable(MyVariation,PChar(Name),value); + Result := PluginData.PluginVarGetVariable(MyVariation,PAnsiChar(AnsiString(Name)),value); end; /////////////////////////////////////////////////////////////////////////////// @@ -229,16 +230,17 @@ function TPluginVariation.ResetVariable(const Name: string) : boolean; dummy: double; begin if @PluginData.PluginVarResetVariable <> nil then - Result := PluginData.PluginVarResetVariable(MyVariation, PChar(Name)) + Result := PluginData.PluginVarResetVariable(MyVariation, PAnsiChar(AnsiString(Name))) else begin dummy := 0; - Result := PluginData.PluginVarSetVariable(MyVariation,PChar(Name), dummy); + Result := PluginData.PluginVarSetVariable(MyVariation,PAnsiChar(AnsiString(Name)), dummy); end; end; /////////////////////////////////////////////////////////////////////////////// procedure InitializePlugins; var + Registry: TRegistry; searchResult: TSearchRec; name, msg: string; PluginData : TPluginData; @@ -246,19 +248,30 @@ procedure InitializePlugins; errstr:string; begin NumBuiltinVars := NRLOCVAR + GetNrRegisteredVariations; - Exit; - - - /////// DECEPRATED - TAKEN OVER BY MAPM + Registry := TRegistry.Create; + try + Registry.RootKey := HKEY_CURRENT_USER; + { Defaults } + if Registry.OpenKey('Software\' + APP_NAME + '\Defaults', False) then + if Registry.ValueExists('PluginPath') then begin + PluginPath := Registry.ReadString('PluginPath'); + end else begin + PluginPath := ExtractFilePath(Application.ExeName) + 'Plugins\'; + end + else PluginPath := ExtractFilePath(Application.ExeName) + 'Plugins\'; + Registry.CloseKey; + finally + Registry.Free; + end; // Try to find regular files matching *.dll in the plugins dir - if FindFirst(ExtractFilePath(Application.ExeName) + 'Plugins\*.dll', faAnyFile, searchResult) = 0 then + if FindFirst(PluginPath + '*.dll', faAnyFile, searchResult) = 0 then begin repeat with PluginData do begin //Load DLL and initialize plugins! - PluginHandle := LoadLibrary(PChar(ExtractFilePath(Application.ExeName) + 'Plugins\' + searchResult.Name)); + PluginHandle := LoadLibrary(PChar(PluginPath + searchResult.Name)); if PluginHandle<>0 then begin @PluginVarGetName := GetProcAddress(PluginHandle,'PluginVarGetName'); if @PluginVarGetName = nil then begin // Must not be a valid plugin! @@ -266,7 +279,7 @@ procedure InitializePlugins; msg := msg + 'Invalid plugin type: "' + searchResult.Name + '" is not a plugin' + #13#10; continue; end; - name := PluginVarGetName; + name := String(PluginVarGetName); if GetVariationIndex(name) >= 0 then begin FreeLibrary(PluginHandle); msg := msg + 'Cannot load plugin from ' + searchResult.Name + ': variation "' + name + '" already exists!' + #13#10; @@ -286,6 +299,7 @@ procedure InitializePlugins; @PluginVarResetVariable := GetProcAddress(PluginHandle,'PluginVarResetVariable'); RegisterVariation(TVariationPluginLoader.Create(PluginData), @PluginVarInit3D <> nil, @PluginVarInitDC <> nil); + RegisterVariationFile(ExtractFilePath(Application.ExeName) + 'Plugins\' + searchResult.Name, name); end; end else begin errno := GetLastError; @@ -304,7 +318,6 @@ procedure InitializePlugins; end; /////////////////////////////////////////////////////////////////////////////// -initialization - InitializePlugins; + end. diff --git a/Source/Variations/varHemisphere.pas b/Source/Variations/varHemisphere.pas index cecbde2..dfa1637 100644 --- a/Source/Variations/varHemisphere.pas +++ b/Source/Variations/varHemisphere.pas @@ -57,7 +57,6 @@ implementation /////////////////////////////////////////////////////////////////////////////// procedure TVariationHemisphere.CalcFunction; -{$ifndef _ASM_} var t: double; begin @@ -66,30 +65,6 @@ procedure TVariationHemisphere.CalcFunction; FPx^ := FPx^ + FTx^ * t; FPy^ := FPy^ + FTy^ * t; FPz^ := FPz^ + t; -{$else} -asm - mov edx, [eax + FTx] - fld qword ptr [edx + 8] // FTy - fld qword ptr [edx] // FTx - fld st(1) - fmul st, st - fld st(1) - fmul st, st - faddp - fld1 - faddp - fsqrt - fdivr qword ptr [eax + vvar] - fmul st(2), st - fmul st(1), st - fadd qword ptr [edx + 40] // FPz - fstp qword ptr [edx + 40] - fadd qword ptr [edx + 16] // FPx - fstp qword ptr [edx + 16] - fadd qword ptr [edx + 24] // FPy - fstp qword ptr [edx + 24] - fwait -{$endif} end; /////////////////////////////////////////////////////////////////////////////// diff --git a/Source/Variations/varJulia3Djf.pas b/Source/Variations/varJulia3Djf.pas index 49a3b07..289b18e 100644 --- a/Source/Variations/varJulia3Djf.pas +++ b/Source/Variations/varJulia3Djf.pas @@ -26,13 +26,20 @@ interface uses - BaseVariation, XFormMan, AsmRandom; +{$ifdef Apo7X64} +{$else} +AsmRandom, +{$endif} + BaseVariation, XFormMan; const var_name = 'julia3D'; var_n_name='julia3D_power'; -{$define _ASM_} +{$ifdef Apo7X64} +{$else} + {$define _ASM_} +{$endif} type TVariationJulia3DJF = class(TBaseVariation) diff --git a/Source/Variations/varJulia3Dz.pas b/Source/Variations/varJulia3Dz.pas index 953dc22..86bb865 100644 --- a/Source/Variations/varJulia3Dz.pas +++ b/Source/Variations/varJulia3Dz.pas @@ -26,13 +26,20 @@ interface uses - BaseVariation, XFormMan, AsmRandom; +{$ifdef Apo7X64} +{$else} +AsmRandom, +{$endif} + BaseVariation, XFormMan; const var_name = 'julia3Dz'; var_n_name='julia3Dz_power'; -{$define _ASM_} +{$ifdef Apo7X64} +{$else} + {$define _ASM_} +{$endif} type TVariationJulia3D = class(TBaseVariation) diff --git a/Source/Variations/varJuliaN.pas b/Source/Variations/varJuliaN.pas index ebf0867..0f8f90f 100644 --- a/Source/Variations/varJuliaN.pas +++ b/Source/Variations/varJuliaN.pas @@ -3,14 +3,17 @@ interface uses - BaseVariation, XFormMan, AsmRandom; + BaseVariation, XFormMan; const var_name = 'julian'; var_n_name='julian_power'; var_c_name='julian_dist'; -{$define _ASM_} +{$ifdef Apo7X64} +{$else} + {$define _ASM_} +{$endif} type TVariationJulian = class(TBaseVariation) @@ -81,7 +84,6 @@ procedure TVariationJulian.GetCalcFunction(var f: TCalcFunction); /////////////////////////////////////////////////////////////////////////////// procedure TVariationJulian.CalcFunction; -{$ifndef _ASM_} var r: double; sina, cosa: extended; @@ -91,59 +93,10 @@ procedure TVariationJulian.CalcFunction; FPx^ := FPx^ + r * cosa; FPy^ := FPy^ + r * sina; -{$else} -asm - mov edx, [eax + FTx] - fld qword ptr [edx] // FTx - fld qword ptr [edx + 8] // FTy - fld qword ptr [eax + cN] - fld st(2) - fmul st, st - fld st(2) - fmul st, st - faddp -// --- x^y = 2^(y*log2(x)) - fyl2x - fld st - frndint - fsub st(1), st - fxch st(1) - f2xm1 - fld1 - fadd - fscale - fstp st(1) -// --- - fmul qword ptr [eax + vvar] - - fxch st(2) - fpatan - mov ecx, eax - mov eax, dword ptr [eax + absN] - call AsmRandInt - push eax - fild dword ptr [esp] - add esp, 4 - fldpi - fadd st, st - fmulp - faddp - fidiv dword ptr [ecx + N] - fsincos - - fmul st, st(2) - mov edx, [ecx + FPx] - fadd qword ptr [edx] // FPx - fstp qword ptr [edx] - fmulp - fadd qword ptr [edx + 8] // FPy - fstp qword ptr [edx + 8] - fwait -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; procedure TVariationJulian.CalcPower2; -{$ifndef _ASM_} var d: double; begin @@ -157,44 +110,11 @@ procedure TVariationJulian.CalcPower2; FPx^ := FPx^ - vvar2 * d; FPy^ := FPy^ - vvar2 / d * FTy^; end; -{$else} -asm - mov edx, [eax + FTx] - fld qword ptr [edx + 8] // FTy - fld qword ptr [edx] // FTx - fld st(1) - fmul st,st - fld st(1) - fmul st,st - faddp - fsqrt - faddp - fsqrt - - fld qword ptr [eax + vvar2] - mov ecx,eax - mov eax,2 - call AsmRandInt; - shr eax,1 - jc @skip - fchs -@skip: - - fmul st(2),st - fmul st,st(1) - - mov edx, [ecx + FPx] - fadd qword ptr [edx] - fstp qword ptr [edx] - fdivp st(1),st - fadd qword ptr [edx + 8] - fstp qword ptr [edx + 8] - fwait -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; procedure TVariationJulian.CalcPowerMinus2; -{$ifndef _ASM_} + var r, xd: double; begin @@ -211,75 +131,17 @@ procedure TVariationJulian.CalcPowerMinus2; FPx^ := FPx^ - r * xd; FPy^ := FPy^ + r * FTy^; end; -{$else} -asm - - mov edx, [eax + FTx] - fld qword ptr [edx + 8] - fld qword ptr [edx] - fld st(1) - fmul st,st - fld st(1) - fmul st,st - faddp - fsqrt - fadd st(1),st - fld st(1) - fmul st,st - fld st(3) - fmul st,st - faddp - fmulp - fsqrt - - fdivr qword ptr [eax + vvar] - - mov ecx,eax - mov eax,2 - call AsmRandInt; - shr eax,1 - jc @skip - fchs -@skip: - - fmul st(1),st - fmulp st(2),st - - mov edx, [ecx + FPx] - fsubr qword ptr [edx] - fstp qword ptr [edx] - fadd qword ptr [edx + 8] - fstp qword ptr [edx + 8] - fwait -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; procedure TVariationJulian.CalcPower1; -{$ifndef _ASM_} begin FPx^ := FPx^ + vvar * FTx^; FPy^ := FPy^ + vvar * FTy^; -{$else} -asm - mov edx, [eax + FTx] //[eax + FTy] - fld qword ptr [edx] -// mov edx, [eax + FTx] - fld qword ptr [edx + 8] - fld qword ptr [eax + vvar] - fmul st(2), st - fmulp -// mov edx, [eax + FPx] - fadd qword ptr [edx + 16] - fstp qword ptr [edx + 16] -// mov edx, [eax + FPy] - fadd qword ptr [edx + 24] - fstp qword ptr [edx + 24] - fwait -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; procedure TVariationJulian.CalcPowerMinus1; -{$ifndef _ASM_} var r: double; begin @@ -287,28 +149,7 @@ procedure TVariationJulian.CalcPowerMinus1; FPx^ := FPx^ + r * FTx^; FPy^ := FPy^ - r * FTy^; -{$else} -asm - mov edx, [eax + FTx] - fld qword ptr [edx + 8] // FTy -// mov edx, [eax + FTx] - fld qword ptr [edx] // FTx - fld st(1) - fmul st, st - fld st(1) - fmul st, st - faddp - fdivr qword ptr [eax + vvar] - fmul st(2), st - fmulp -// mov edx, [eax + FPx] - fadd qword ptr [edx + 16] // FPx - fstp qword ptr [edx + 16] // FPx -// mov edx, [eax + FPy] - fsubr qword ptr [edx + 24] // FPy - fstp qword ptr [edx + 24] // FPy - fwait -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; /////////////////////////////////////////////////////////////////////////////// @@ -386,6 +227,6 @@ function TVariationJulian.GetVariable(const Name: string; var value: double): bo /////////////////////////////////////////////////////////////////////////////// initialization - RegisterVariation(TVariationClassLoader.Create(TVariationJulian), false, false); + RegisterVariation(TVariationClassLoader.Create(TVariationJulian), true, false); end. diff --git a/Source/Variations/varJuliaScope.pas b/Source/Variations/varJuliaScope.pas index 3d0bb72..70f1818 100644 --- a/Source/Variations/varJuliaScope.pas +++ b/Source/Variations/varJuliaScope.pas @@ -26,14 +26,17 @@ interface uses - BaseVariation, XFormMan, AsmRandom; + BaseVariation, XFormMan; const variation_name='juliascope'; var_n_name='juliascope_power'; var_c_name='juliascope_dist'; -{$define _ASM_} +{$ifdef Apo7X64} +{$else} + {$define _ASM_} +{$endif} type TVariationJuliaScope = class(TBaseVariation) @@ -102,7 +105,6 @@ procedure TVariationJuliaScope.GetCalcFunction(var f: TCalcFunction); /////////////////////////////////////////////////////////////////////////////// procedure TVariationJuliaScope.CalcFunction; -{$ifndef _ASM_} var rnd: integer; r: double; @@ -116,68 +118,10 @@ procedure TVariationJuliaScope.CalcFunction; r := vvar * Math.Power(sqr(FTx^) + sqr(FTy^), cn); FPx^ := FPx^ + r * cosa; FPy^ := FPy^ + r * sina; -{$else} -asm - mov edx, [eax + FTy] - fld qword ptr [edx] - fld qword ptr [eax + cn] - mov edx, [eax + FTx] - fld qword ptr [edx] - fld st(2) - fld st(1) - fpatan - mov ecx, eax - mov eax, dword ptr [eax + rN] - call AsmRandInt - push eax - - shr eax, 1 - jnc @even - fchs -@even: - - fldpi - fadd st, st - fimul dword ptr [esp] - add esp, 4 - faddp - fidiv dword ptr [ecx + N] - - fxch st(3) - fmul st, st - fxch st(1) - fmul st, st - faddp -// --- x^y = 2^(y*log2(x)) - fyl2x - fld st - frndint - fsub st(1), st - fxch st(1) - f2xm1 - fld1 - fadd - fscale - fstp st(1) -// --- - fmul qword ptr [ecx + vvar] - fxch st(1) - fsincos - fmul st, st(2) - - mov edx, [ecx + FPx] - fadd qword ptr [edx] - fstp qword ptr [edx] - fmulp - mov edx, [ecx + FPy] - fadd qword ptr [edx] - fstp qword ptr [edx] - fwait -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; procedure TVariationJuliaScope.CalcPower2; -//{$ifndef _ASM_} var r: double; sina, cosa: extended; @@ -191,67 +135,10 @@ procedure TVariationJuliaScope.CalcPower2; FPx^ := FPx^ + r * cosa; FPy^ := FPy^ + r * sina; -(*{$else} -asm - mov edx, [eax + FTy] - fld qword ptr [edx] - mov edx, [eax + FTx] - fld qword ptr [edx] - fld st(1) - fld st(1) - fpatan - fld1 - fadd st, st - fdivp st(1), st - mov ecx, eax - //mov eax, 2 - call System.@RandInt - - shr eax, 1 - jnc @skip - fldpi - fsubrp st(1), st -@skip: - -{ - push eax - - shr eax, 1 - jnc @even - fchs -@even: - - fldpi - fimul dword ptr [esp] - add esp, 4 - faddp -} - fxch st(2) - fmul st, st - fxch st(1) - fmul st, st - faddp - fsqrt - fsqrt - fmul qword ptr [ecx + vvar] - fxch st(1) - - fsincos - - fmul st, st(2) - mov edx, [ecx + FPx] - fadd qword ptr [edx] - fstp qword ptr [edx] - fmulp - mov edx, [ecx + FPy] - fadd qword ptr [edx] - fstp qword ptr [edx] - fwait -{$endif} *) + FPz^ := FPz^ + vvar * FTz^; end; procedure TVariationJuliaScope.CalcPowerMinus2; -//{$ifndef _ASM_} var r: double; sina, cosa: extended; @@ -264,90 +151,17 @@ procedure TVariationJuliaScope.CalcPowerMinus2; FPx^ := FPx^ + r * cosa; FPy^ := FPy^ - r * sina; -(*{$else} -asm - mov edx, [eax + FTy] - fld qword ptr [edx] - mov edx, [eax + FTx] - fld qword ptr [edx] - fld st(1) - fld st(1) - fpatan - fld1 - fadd st, st - fdivp st(1), st - mov ecx, eax - mov eax, 2 - call System.@RandInt - - shr eax, 1 - jnc @skip - fldpi - fsubrp st(1), st -@skip: - -{ push eax - - shr eax, 1 - jnc @even - fchs -@even: - - fldpi - fimul dword ptr [esp] - add esp, 4 - faddp -} { - fxch st(2) - fmul st, st - fxch st(1) - fmul st, st - faddp - fsqrt - fsqrt - fdivr qword ptr [ecx + vvar] - fxch st(1) - - fsincos - - fmul st, st(2) - mov edx, [ecx + FPx] - fadd qword ptr [edx] - fstp qword ptr [edx] - fmulp - mov edx, [ecx + FPy] - fsubr qword ptr [edx] - fstp qword ptr [edx] - fwait -{$endif} *) + FPz^ := FPz^ + vvar * FTz^; end; procedure TVariationJuliaScope.CalcPower1; -{$ifndef _ASM_} begin FPx^ := FPx^ + vvar * FTx^; FPy^ := FPy^ + vvar * FTy^; -{$else} -asm - mov edx, [eax + FTy] - fld qword ptr [edx] - mov edx, [eax + FTx] - fld qword ptr [edx] - fld qword ptr [eax + vvar] - fmul st(2), st - fmulp - mov edx, [eax + FPx] - fadd qword ptr [edx] - fstp qword ptr [edx] - mov edx, [eax + FPy] - fadd qword ptr [edx] - fstp qword ptr [edx] - fwait -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; procedure TVariationJuliaScope.CalcPowerMinus1; -{$ifndef _ASM_} var r: double; begin @@ -355,28 +169,7 @@ procedure TVariationJuliaScope.CalcPowerMinus1; FPx^ := FPx^ + r * FTx^; FPy^ := FPy^ - r * FTy^; -{$else} -asm - mov edx, [eax + FTy] - fld qword ptr [edx] - mov edx, [eax + FTx] - fld qword ptr [edx] - fld st(1) - fmul st, st - fld st(1) - fmul st, st - faddp - fdivr qword ptr [eax + vvar] - fmul st(2), st - fmulp - mov edx, [eax + FPx] - fadd qword ptr [edx] - fstp qword ptr [edx] - mov edx, [eax + FPy] - fsubr qword ptr [edx] - fstp qword ptr [edx] - fwait -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; /////////////////////////////////////////////////////////////////////////////// @@ -454,5 +247,5 @@ function TVariationJuliaScope.GetVariable(const Name: string; var value: double) /////////////////////////////////////////////////////////////////////////////// initialization - RegisterVariation(TVariationClassLoader.Create(TVariationJuliaScope), false, false); + RegisterVariation(TVariationClassLoader.Create(TVariationJuliaScope), true, false); end. diff --git a/Source/Variations/varLazysusan.pas b/Source/Variations/varLazysusan.pas new file mode 100644 index 0000000..a02a634 --- /dev/null +++ b/Source/Variations/varLazysusan.pas @@ -0,0 +1,195 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + You should have received a copy of the GNU General Public License + GNU General Public License for more details. + + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varLazysusan; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationLazysusan = class(TBaseVariation) + private + lazysusan_spin, lazysusan_space, lazysusan_twist : double; + lazysusan_x, lazysusan_y : double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationLazysusan.Prepare; +begin +end; +procedure TVariationLazysusan.CalcFunction; +var + a, r, sina, cosa, x, y: double; +begin + x := FTx^ - lazysusan_x; + y := FTy^ + lazysusan_y; + r := sqrt(x*x + y*y); + + if (r < VVAR) then + begin + a := ArcTan2(y, x) + lazysusan_spin + lazysusan_twist*(VVAR-r); + sincos(a, sina, cosa); + FPx^ := FPx^ + VVAR * (r*cosa + lazysusan_x); + FPy^ := FPy^ + VVAR * (r*sina - lazysusan_y); + end else begin + r := 1.0 + lazysusan_space / (r + 1E-6); + FPx^ := FPx^ + VVAR * (r*x + lazysusan_x); + FPy^ := FPy^ + VVAR * (r*y - lazysusan_y); + end; + + FPz^ := FPz^ + VVAR * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationLazysusan.Create; +begin + lazysusan_spin := PI; + lazysusan_space := 0; + lazysusan_twist := 0; + lazysusan_x := 0; + lazysusan_y := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationLazysusan.GetInstance: TBaseVariation; +begin + Result := TVariationLazysusan.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationLazysusan.GetName: string; +begin + Result := 'lazysusan'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationLazysusan.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'lazysusan_spin'; + 1: Result := 'lazysusan_space'; + 2: Result := 'lazysusan_twist'; + 3: Result := 'lazysusan_x'; + 4: Result := 'lazysusan_y'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationLazysusan.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'lazysusan_spin' then begin + Value := frac(value / (2 * PI)) * (2 * PI); + lazysusan_spin := value; + Result := True; + end else if Name = 'lazysusan_space' then begin + lazysusan_space := Value; + Result := True; + end else if Name = 'lazysusan_twist' then begin + lazysusan_twist := Value; + Result := True; + end else if Name = 'lazysusan_x' then begin + lazysusan_x := Value; + Result := True; + end else if Name = 'lazysusan_y' then begin + lazysusan_y := Value; + Result := True; + end; +end; +function TVariationLazysusan.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'lazysusan_spin' then begin + lazysusan_spin := PI; + Result := True; + end else if Name = 'lazysusan_space' then begin + lazysusan_space := 0; + Result := True; + end else if Name = 'lazysusan_twist' then begin + lazysusan_twist := 0; + Result := True; + end else if Name = 'lazysusan_x' then begin + lazysusan_x := 0; + Result := True; + end else if Name = 'lazysusan_y' then begin + lazysusan_x := 0; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationLazysusan.GetNrVariables: integer; +begin + Result := 5 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationLazysusan.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'lazysusan_spin' then begin + Value := lazysusan_spin; + Result := True; + end else if Name = 'lazysusan_space' then begin + Value := lazysusan_space; + Result := True; + end else if Name = 'lazysusan_twist' then begin + Value := lazysusan_twist; + Result := True; + end else if Name = 'lazysusan_x' then begin + Value := lazysusan_x; + Result := True; + end else if Name = 'lazysusan_y' then begin + Value := lazysusan_y; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationLazysusan), true, false); +end. diff --git a/Source/Variations/varLog.pas b/Source/Variations/varLog.pas new file mode 100644 index 0000000..2cc0a64 --- /dev/null +++ b/Source/Variations/varLog.pas @@ -0,0 +1,139 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varLog; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationLog = class(TBaseVariation) + private + base, denom: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +{ TVariationPreSpherical } + + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationLog.Prepare; +begin + denom := 0.5 / Ln(base); +end; +procedure TVariationLog.CalcFunction; +begin + FPx^ := FPx^ + vvar * Ln(sqr(FTx^) + sqr(FTy^)) * denom; + FPy^ := FPy^ + vvar * ArcTan2(FTy^, FTx^); + FPz^ := FPz^ + vvar * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationLog.Create; +begin + base := 2.71828182845905; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationLog.GetInstance: TBaseVariation; +begin + Result := TVariationLog.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationLog.GetName: string; +begin + Result := 'log'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationLog.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'log_base'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationLog.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'log_base' then begin + base := Value; + if (base < 1E-6) then + base := 1E-6; + Result := True; + end; +end; +function TVariationLog.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'log_base' then begin + base := 2.71828182845905; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationLog.GetNrVariables: integer; +begin + Result := 1 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationLog.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'log_base' then begin + Value := base; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationLog), true, false); +end. diff --git a/Source/Variations/varLoonie.pas b/Source/Variations/varLoonie.pas new file mode 100644 index 0000000..36dbae0 --- /dev/null +++ b/Source/Variations/varLoonie.pas @@ -0,0 +1,131 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varLoonie; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationLoonie = class(TBaseVariation) + private + sqrvar: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationLoonie.Prepare; +begin + sqrvar := VVAR * VVAR; +end; + +procedure TVariationLoonie.CalcFunction; +var r, r2 : double; +begin + r2 := sqr(FTx^) + sqr(FTy^); + + if (r2 < (sqrvar)) and (r2 <> 0) then + begin + r := VVAR * sqrt((sqrvar) / r2 - 1.0); + FPx^ := FPx^ + r * FTx^; + FPy^ := FPy^ + r * FTy^; + end else begin + FPx^ := FPx^ + VVAR * FTx^; + FPy^ := FPy^ + VVAR * FTy^; + end; + + FPz^ := FPz^ + vvar * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationLoonie.Create; +begin + sqrvar := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationLoonie.GetInstance: TBaseVariation; +begin + Result := TVariationLoonie.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationLoonie.GetName: string; +begin + Result := 'loonie'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationLoonie.GetVariableNameAt(const Index: integer): string; +begin + Result := ''; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationLoonie.SetVariable(const Name: string; var value: double): boolean; +var temp: double; +begin + Result := False; +end; +function TVariationLoonie.ResetVariable(const Name: string): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationLoonie.GetNrVariables: integer; +begin + Result := 0 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationLoonie.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationLoonie), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varMobius.pas b/Source/Variations/varMobius.pas new file mode 100644 index 0000000..964d123 --- /dev/null +++ b/Source/Variations/varMobius.pas @@ -0,0 +1,216 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varMobius; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationMobius = class(TBaseVariation) + private + Re_A, Im_A, Re_B, Im_B, Re_C, Im_C, Re_D, Im_D: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationMobius.Prepare; +begin +end; + +procedure TVariationMobius.CalcFunction; +var + uRe, uIm, vRe, vIm, vDenom : double; +begin + uRe := (Re_A) * FTX^ - (Im_A) * FTY^ + (Re_B); + uIm := (Re_A) * FTY^ + (Im_A) * FTX^ + (Im_B); + vRe := (Re_C) * FTX^ - (Im_C) * FTY^ + (Re_D); + vIm := (Re_C) * FTY^ + (Im_C) * FTX^ + (Im_D); + + vDenom := vRe * vRe + vIm * vIm; + + FPx^ := FPx^ + VVAR * (uRe*vRe + uIm*vIm) / vDenom; + FPy^ := FPy^ + VVAR * (uIm*vRe - uRe*vIm) / vDenom; + FPz^ := FPz^ + VVAR * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationMobius.Create; +begin + Re_A := 1; Im_A := 0; + Re_B := 0; Im_B := 0; + Re_C := 0; Im_C := 0; + Re_D := 1; Im_D := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationMobius.GetInstance: TBaseVariation; +begin + Result := TVariationMobius.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationMobius.GetName: string; +begin + Result := 'mobius'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationMobius.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'Re_A'; + 1: Result := 'Im_A'; + 2: Result := 'Re_B'; + 3: Result := 'Im_B'; + 4: Result := 'Re_C'; + 5: Result := 'Im_C'; + 6: Result := 'Re_D'; + 7: Result := 'Im_D'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationMobius.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'Re_A' then begin + Re_A := Value; + Result := True; + end else if Name = 'Im_A' then begin + Im_A := Value; + Result := True; + end else if Name = 'Re_B' then begin + Re_B := Value; + Result := True; + end else if Name = 'Im_B' then begin + Im_B := Value; + Result := True; + end else if Name = 'Re_C' then begin + Re_C := Value; + Result := True; + end else if Name = 'Im_C' then begin + Im_C := Value; + Result := True; + end else if Name = 'Re_D' then begin + Re_D := Value; + Result := True; + end else if Name = 'Im_D' then begin + Im_D := Value; + Result := True; + end +end; +function TVariationMobius.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'Re_A' then begin + Re_A := 1; + Result := True; + end else if Name = 'Im_A' then begin + Im_A := 0; + Result := True; + end else if Name = 'Re_B' then begin + Re_B := 0; + Result := True; + end else if Name = 'Im_B' then begin + Im_B := 0; + Result := True; + end else if Name = 'Re_C' then begin + Re_C := 0; + Result := True; + end else if Name = 'Im_C' then begin + Im_C := 0; + Result := True; + end else if Name = 'Re_D' then begin + Re_D := 1; + Result := True; + end else if Name = 'Im_D' then begin + Im_D := 0; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationMobius.GetNrVariables: integer; +begin + Result := 8 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationMobius.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'Re_A' then begin + Value := Re_A; + Result := True; + end else if Name = 'Im_A' then begin + Value := Im_A; + Result := True; + end else if Name = 'Re_B' then begin + Value := Re_B; + Result := True; + end else if Name = 'Im_B' then begin + Value := Im_B; + Result := True; + end else if Name = 'Re_C' then begin + Value := Re_C; + Result := True; + end else if Name = 'Im_C' then begin + Value := Im_C; + Result := True; + end else if Name = 'Re_D' then begin + Value := Re_D; + Result := True; + end else if Name = 'Im_D' then begin + Value := Im_D; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationMobius), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varNGon.pas b/Source/Variations/varNGon.pas new file mode 100644 index 0000000..b52422a --- /dev/null +++ b/Source/Variations/varNGon.pas @@ -0,0 +1,187 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + You should have received a copy of the GNU General Public License + GNU General Public License for more details. + + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varNGon; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationNGon = class(TBaseVariation) + private + ngon_sides : integer; + ngon_power, ngon_circle, ngon_corners : double; + cpower, csides, csidesinv : double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationNGon.Prepare; +begin + cpower := -0.5 * ngon_power; + csides := 2.0 * PI / ngon_sides; + csidesinv := 1.0 / csides; +end; +procedure TVariationNGon.CalcFunction; +var + r_factor, theta, phi, amp: double; +begin + + if (FTX^ = 0) and (FTY^ = 0) then r_factor := 0 + else r_factor := Power(FTx^ * FTx^ + FTy^ * FTy^, cpower); + + theta := ArcTan2(FTy^, FTx^); + + phi := theta - csides * floor(theta * csidesinv); + if (phi > 0.5 * csides) then + phi := phi - csides; + + amp := (ngon_corners * (1.0 / cos(phi) - 1.0) + ngon_circle) * VVAR * r_factor; + + FPx^ := FPx^ + amp * FTx^; + FPy^ := FPy^ + amp * FTy^; + FPz^ := FPz^ + VVAR * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationNGon.Create; +begin + ngon_sides := 4; + ngon_power := 2; + ngon_circle := 1; + ngon_corners := 1; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationNGon.GetInstance: TBaseVariation; +begin + Result := TVariationNGon.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationNGon.GetName: string; +begin + Result := 'ngon'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationNGon.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'ngon_sides'; + 1: Result := 'ngon_power'; + 2: Result := 'ngon_circle'; + 3: Result := 'ngon_corners'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationNGon.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'ngon_sides' then begin + if (value < 0) and (value > -1) then Value := -1 + else if (value >= 0) and (value < 1) then Value := 1; + ngon_sides := Round(value); + Result := True; + end else if Name = 'ngon_power' then begin + ngon_power := Value; + Result := True; + end else if Name = 'ngon_circle' then begin + ngon_circle := Value; + Result := True; + end else if Name = 'ngon_corners' then begin + ngon_corners := Value; + Result := True; + end; +end; +function TVariationNGon.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'ngon_sides' then begin + ngon_sides := 4; + Result := True; + end else if Name = 'ngon_power' then begin + ngon_power := 2; + Result := True; + end else if Name = 'ngon_circle' then begin + ngon_circle := 1; + Result := True; + end else if Name = 'ngon_corners' then begin + ngon_corners := 1; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationNGon.GetNrVariables: integer; +begin + Result := 4 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationNGon.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'ngon_sides' then begin + Value := ngon_sides; + Result := True; + end else if Name = 'ngon_power' then begin + Value := ngon_power; + Result := True; + end else if Name = 'ngon_circle' then begin + Value := ngon_circle; + Result := True; + end else if Name = 'ngon_corners' then begin + Value := ngon_corners; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationNGon), true, false); +end. diff --git a/Source/Variations/varPolar2.pas b/Source/Variations/varPolar2.pas new file mode 100644 index 0000000..216b42c --- /dev/null +++ b/Source/Variations/varPolar2.pas @@ -0,0 +1,114 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varPolar2; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationPolar2 = class(TBaseVariation) + private + p2vv, p2vv2: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationPolar2.Prepare; +begin + p2vv := VVAR / PI; + p2vv2 := p2vv * 0.5; +end; + +procedure TVariationPolar2.CalcFunction; +begin + FPy^ := FPy^ + p2vv2 * Ln(sqr(FTx^) + sqr(FTy^)); + FPx^ := FPx^ + p2vv * ArcTan2(FTx^, FTy^); + FPz^ := FPz^ + vvar * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationPolar2.Create; +begin +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPolar2.GetInstance: TBaseVariation; +begin + Result := TVariationPolar2.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPolar2.GetName: string; +begin + Result := 'polar2'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPolar2.GetVariableNameAt(const Index: integer): string; +begin + Result := ''; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPolar2.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPolar2.GetNrVariables: integer; +begin + Result := 0 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPolar2.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationPolar2), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varPostBwraps.pas b/Source/Variations/varPostBwraps.pas new file mode 100644 index 0000000..69807a2 --- /dev/null +++ b/Source/Variations/varPostBwraps.pas @@ -0,0 +1,228 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varPostBwraps; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationPostBwraps = class(TBaseVariation) + private + post_bwraps_cellsize, post_bwraps_space, post_bwraps_gain, + post_bwraps_inner_twist, post_bwraps_outer_twist, + g2, r2, rfactor: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationPostBwraps.Prepare; +var + max_bubble, radius: double; +begin + radius := 0.5 * (post_bwraps_cellsize / (1.0 + sqr(post_bwraps_space))); + g2 := sqr(post_bwraps_gain) / (radius + 1e-6) + 1e-6; + max_bubble := g2 * radius; + + if (max_bubble > 2.0) then max_bubble := 1.0 + else max_bubble := max_bubble * (1.0 / (sqr(max_bubble)/4.0 + 1.0)); + + r2 := sqr(radius); + rfactor := radius / max_bubble; +end; + +procedure TVariationPostBwraps.CalcFunction; +var + Vx, Vy, + Cx, Cy, + Lx, Ly, + r, theta, s, c : double; +begin + Vx := FPx^; + Vy := FPy^; + + if (post_bwraps_cellsize <> 0.0) then + begin + Cx := (floor(Vx / post_bwraps_cellsize) + 0.5) * post_bwraps_cellsize; + Cy := (floor(Vy / post_bwraps_cellsize) + 0.5) * post_bwraps_cellsize; + + Lx := Vx - Cx; + Ly := Vy - Cy; + + if ((sqr(Lx) + sqr(Ly)) <= r2) then + begin + Lx := Lx * g2; + Ly := Ly * g2; + + r := rfactor / ((sqr(Lx) + sqr(Ly)) / 4.0 + 1); + + Lx := Lx * r; + Ly := Ly * r; + + r := (sqr(Lx) + sqr(Ly)) / r2; + theta := post_bwraps_inner_twist * (1.0 - r) + post_bwraps_outer_twist * r; + SinCos(theta, s, c); + + Vx := Cx + c * Lx + s * Ly; + Vy := Cy - s * Lx + c * Ly; + + FPx^ := VVAR * Vx; + FPy^ := VVAR * Vy; + FPz^ := VVAR * FPz^; + end; + end; + +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationPostBwraps.Create; +begin + post_bwraps_cellsize := 1; + post_bwraps_space := 0; + post_bwraps_gain := 1; + post_bwraps_inner_twist := 0; + post_bwraps_outer_twist := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPostBwraps.GetInstance: TBaseVariation; +begin + Result := TVariationPostBwraps.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPostBwraps.GetName: string; +begin + Result := 'post_bwraps'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostBwraps.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'post_bwraps_cellsize'; + 1: Result := 'post_bwraps_space'; + 2: Result := 'post_bwraps_gain'; + 3: Result := 'post_bwraps_inner_twist'; + 4: Result := 'post_bwraps_outer_twist'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostBwraps.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'post_bwraps_cellsize' then begin + if Value = 0 then Value := 1e-6; + post_bwraps_cellsize := Value; + Result := True; + end else if Name = 'post_bwraps_space' then begin + post_bwraps_space := Value; + Result := True; + end else if Name = 'post_bwraps_gain' then begin + post_bwraps_gain := Value; + Result := True; + end else if Name = 'post_bwraps_inner_twist' then begin + post_bwraps_inner_twist := Value; + Result := True; + end else if Name = 'post_bwraps_outer_twist' then begin + post_bwraps_outer_twist := Value; + Result := True; + end +end; +function TVariationPostBwraps.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'post_bwraps_cellsize' then begin + post_bwraps_cellsize := 1; + Result := True; + end else if Name = 'post_bwraps_space' then begin + post_bwraps_space := 0; + Result := True; + end else if Name = 'post_bwraps_gain' then begin + post_bwraps_gain := 1; + Result := True; + end else if Name = 'post_bwraps_inner_twist' then begin + post_bwraps_inner_twist := 0; + Result := True; + end else if Name = 'post_bwraps_outer_twist' then begin + post_bwraps_outer_twist := 0; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostBwraps.GetNrVariables: integer; +begin + Result := 5 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostBwraps.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'post_bwraps_cellsize' then begin + Value := post_bwraps_cellsize; + Result := True; + end else if Name = 'post_bwraps_space' then begin + Value := post_bwraps_space; + Result := True; + end else if Name = 'post_bwraps_gain' then begin + Value := post_bwraps_gain; + Result := True; + end else if Name = 'post_bwraps_inner_twist' then begin + Value := post_bwraps_inner_twist; + Result := True; + end else if Name = 'post_bwraps_outer_twist' then begin + Value := post_bwraps_outer_twist; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationPostBwraps), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varPostCrop.pas b/Source/Variations/varPostCrop.pas new file mode 100644 index 0000000..04f0fee --- /dev/null +++ b/Source/Variations/varPostCrop.pas @@ -0,0 +1,231 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varPostCrop; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationPostCrop = class(TBaseVariation) + const + n_x0 : string = 'post_crop_left'; + n_y0 : string = 'post_crop_top'; + n_x1 : string = 'post_crop_right'; + n_y1 : string = 'post_crop_bottom'; + n_s : string = 'post_crop_scatter_area'; + n_z : string = 'post_crop_zero'; + n : string = 'post_crop'; + + private + x0, y0, x1, y1, s, w, h: double; + _x0, _y0, _x1, _y1: double; + z: integer; + + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationPostCrop.Prepare; +begin + if (x0 < x1) then begin + _x0 := x0; + _x1 := x1; + end else begin + _x0 := x1; + _x1 := x0; + end; + + if (y0 < y1) then begin + _y0 := y0; + _y1 := y1; + end else begin + _y0 := y1; + _y1 := y0; + end; + + w := (_x1 - _x0) * 0.5 * s; + h := (_y1 - _y0) * 0.5 * s; +end; + +procedure TVariationPostCrop.CalcFunction; +var x, y: double; +begin + x := FPx^; + y := FPy^; + + if ((x < _x0) or (x > _x1) or (y < _y0) or (y > _y1)) and (z <> 0) then begin + x := 0; y := 0; + end else begin + if x < _x0 then x := _x0 + random * w + else if x > _x1 then x := _x1 - random * w; + if y < _y0 then y := _y0 + random * h + else if y > _y1 then y := _y1 - random * h; + end; + + FPx^ := VVAR * x; + FPy^ := VVAR * y; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationPostCrop.Create; +begin + x0 := -1; x1 := 1; + y0 := -1; y1 := 1; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPostCrop.GetInstance: TBaseVariation; +begin + Result := TVariationPostCrop.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPostCrop.GetName: string; +begin + Result := n; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostCrop.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := n_x0; + 1: Result := n_y0; + 2: Result := n_x1; + 3: Result := n_y1; + 4: Result := n_s; + 5: Result := n_z; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostCrop.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = n_x0 then begin + x0 := Value; + Result := True; + end else if Name = n_y0 then begin + y0 := Value; + Result := True; + end else if Name = n_x1 then begin + x1 := Value; + Result := True; + end else if Name = n_y1 then begin + y1 := Value; + Result := True; + end else if Name = n_s then begin + if (Value < -1) then Value := -1; + if (Value > 1) then Value := 1; + s := Value; + Result := True; + end else if Name = n_z then begin + if (Value > 1) then Value := 1; + if (Value < 0) then Value := 0; + z := Round(Value); + Result := True; + end +end; +function TVariationPostCrop.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = n_x0 then begin + x0 := -1; + Result := True; + end else if Name = n_y0 then begin + y0 := -1; + Result := True; + end else if Name = n_x1 then begin + x1 := 1; + Result := True; + end else if Name = n_y1 then begin + y1 := 1; + Result := True; + end else if Name = n_s then begin + s := 0; + Result := True; + end else if Name = n_z then begin + z := 0; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostCrop.GetNrVariables: integer; +begin + Result := 6 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostCrop.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = n_x0 then begin + Value := x0; + Result := True; + end else if Name = n_y0 then begin + Value := y0; + Result := True; + end else if Name = n_x1 then begin + Value := x1; + Result := True; + end else if Name = n_y1 then begin + Value := y1; + Result := True; + end else if Name = n_s then begin + Value := s; + Result := True; + end else if Name = n_z then begin + Value := z; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationPostCrop), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varPostCurl.pas b/Source/Variations/varPostCurl.pas new file mode 100644 index 0000000..3277dcb --- /dev/null +++ b/Source/Variations/varPostCurl.pas @@ -0,0 +1,156 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varPostCurl; + +interface + +uses + BaseVariation, XFormMan; + +const + variation_name = 'post_curl'; + num_vars = 2; + +type + TVariationPostCurl = class(TBaseVariation) + private + c1, c2, c22: double; + public + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +// TVariationCurl3D + +procedure TVariationPostCurl.Prepare; +begin + c1 := c1 * VVAR; + c2 := c2 * VVAR; + c22 := 2 * c2; +end; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationPostCurl.CalcFunction; +var + x, y, r, re, im: double; +begin + x := FPx^; + y := FPy^; + + re := 1 + c1 * x + c2 * (sqr(x) - sqr(y)); + im := c1 * y + c22 * x * y; + + r := sqr(re) + sqr(im); + FPx^ := (x * re + y * im) / r; + FPy^ := (y * re - x * im) / r; +end; +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPostCurl.GetInstance: TBaseVariation; +begin + Result := TVariationPostCurl.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPostCurl.GetName: string; +begin + Result := variation_name; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostCurl.GetVariableNameAt(const Index: integer): string; +begin + case Index of + 0: Result := 'post_curl_c1'; + 1: Result := 'post_curl_c2'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostCurl.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'post_curl_c1' then begin + c1 := value; + Result := True; + end + else if Name = 'post_curl_c2' then begin + c2 := value; + Result := True; + end; +end; + +function TVariationPostCurl.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'post_curl_c1' then begin + c1 := 0; + Result := True; + end + else if Name = 'post_curl_c2' then begin + c2 := 0; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostCurl.GetNrVariables: integer; +begin + Result := num_vars; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostCurl.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'post_curl_c1' then begin + value := c1; + Result := True; + end + else if Name = 'post_curl_c2' then begin + value := c2; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationPostCurl), true, false); +end. diff --git a/Source/Variations/varPostCurl3D.pas b/Source/Variations/varPostCurl3D.pas new file mode 100644 index 0000000..be15d27 --- /dev/null +++ b/Source/Variations/varPostCurl3D.pas @@ -0,0 +1,187 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varPostCurl3D; + +interface + +uses + BaseVariation, XFormMan; + +const + variation_name = 'post_curl3D'; + num_vars = 3; + var_cx_name = 'post_curl3D_cx'; + var_cy_name = 'post_curl3D_cy'; + var_cz_name = 'post_curl3D_cz'; + +type + TVariationPostCurl3D = class(TBaseVariation) + private + cx, cy, cz: double; + + _cx, _cy, _cz, + cx2, cy2, cz2, c_2, + c2x, c2y, c2z: double; + public + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +// TVariationCurl3D + +procedure TVariationPostCurl3D.Prepare; +begin + _cx := VVAR * cx; + _cy := VVAR * cy; + _cz := VVAR * cz; + + c2x := 2 * _cx; + c2y := 2 * _cy; + c2z := 2 * _cz; + + cx2 := sqr(_cx); + cy2 := sqr(_cy); + cz2 := sqr(_cz); + + c_2 := cx2 + cy2 + cz2; +end; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationPostCurl3D.CalcFunction; +var + x, y, z, r, r2: double; +begin + x := Max(-1e100, Min(FPx^, 1e100)); // <--- got weird FP overflow there... + y := Max(-1e100, Min(FPy^, 1e100)); + z := Max(-1e100, Min(FPz^, 1e100)); + + r2 := sqr(x) + sqr(y) + sqr(z); + r := 1.0 / (r2*c_2 + c2x*x - c2y*y + c2z*z + 1); + + FPx^ := r * (x + _cx*r2); + FPy^ := r * (y + _cy*r2); + FPz^ := r * (z + _cz*r2); +end; +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPostCurl3D.GetInstance: TBaseVariation; +begin + Result := TVariationPostCurl3D.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPostCurl3D.GetName: string; +begin + Result := variation_name; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostCurl3D.GetVariableNameAt(const Index: integer): string; +begin + case Index of + 0: Result := var_cx_name; + 1: Result := var_cy_name; + 2: Result := var_cz_name; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostCurl3D.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = var_cx_name then begin + cx := value; + Result := True; + end + else if Name = var_cy_name then begin + cy := value; + Result := True; + end + else if Name = var_cz_name then begin + cz := value; + Result := True; + end; +end; + +function TVariationPostCurl3D.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = var_cx_name then begin + cx := 0; + Result := True; + end + else if Name = var_cy_name then begin + cy := 0; + Result := True; + end + else if Name = var_cz_name then begin + cz := 0; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostCurl3D.GetNrVariables: integer; +begin + Result := num_vars; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostCurl3D.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = var_cx_name then begin + value := cx; + Result := True; + end + else if Name = var_cy_name then begin + value := cy; + Result := True; + end + else if Name = var_cz_name then begin + value := cz; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationPostCurl3D), true, false); +end. diff --git a/Source/Variations/varPostFalloff2.pas b/Source/Variations/varPostFalloff2.pas new file mode 100644 index 0000000..2e5ebed --- /dev/null +++ b/Source/Variations/varPostFalloff2.pas @@ -0,0 +1,348 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varPostFalloff2; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationPostFalloff2 = class(TBaseVariation) + const + n_scatter : string = 'post_falloff2_scatter'; + n_mindist : string = 'post_falloff2_mindist'; + n_mul_x : string = 'post_falloff2_mul_x'; + n_mul_y : string = 'post_falloff2_mul_y'; + n_mul_z : string = 'post_falloff2_mul_z'; + n_mul_c : string = 'post_falloff2_mul_c'; + n_x0 : string = 'post_falloff2_x0'; + n_y0 : string = 'post_falloff2_y0'; + n_z0 : string = 'post_falloff2_z0'; + n_invert : string = 'post_falloff2_invert'; + n_blurtype : string = 'post_falloff2_type'; + + private + rmax: double; + x0, y0, z0: double; + scatter, mindist: double; + invert, blurtype: integer; + mul_x, mul_y, mul_z, mul_c: double; + + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + procedure CalcFunctionRadial; + procedure CalcFunctionGaussian; + procedure GetCalcFunction(var f: TCalcFunction); override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationPostFalloff2.Prepare; +begin + rmax := 0.04 * scatter; +end; + +procedure TVariationPostFalloff2.GetCalcFunction(var f: TCalcFunction); +begin + if blurtype = 1 then f := CalcFunctionRadial + else if blurtype = 2 then f := CalcFunctionGaussian + else f := CalcFunction; +end; +procedure TVariationPostFalloff2.CalcFunction; +var + in_x, in_y, in_z, d: double; +begin + in_x := FPx^; + in_y := FPy^; + in_z := FPz^; + + d := sqrt(sqr(in_x - x0) + sqr(in_y - y0) + sqr(in_z - z0)); + if (invert <> 0) then d := 1 - d; if (d < 0) then d := 0; + d := (d - mindist) * rmax; if (d < 0) then d := 0; + + FPx^ := VVAR * (in_x + mul_x * random * d); + FPy^ := VVAR * (in_y + mul_y * random * d); + FPz^ := VVAR * (in_z + mul_z * random * d); + color^ := Abs(Frac(color^ + mul_c * random * d)); +end; +procedure TVariationPostFalloff2.CalcFunctionRadial; +var + in_x, in_y, in_z, d, r_in: double; + sigma, phi, r, sins, coss, sinp, cosp: double; +begin + in_x := FPx^; + in_y := FPy^; + in_z := FPz^; + + r_in := sqrt(sqr(in_x) + sqr(in_y) + sqr(in_z)) + 1e-6; + d := sqrt(sqr(in_x - x0) + sqr(in_y - y0) + sqr(in_z - z0)); + if (invert <> 0) then d := 1 - d; if (d < 0) then d := 0; + d := (d - mindist) * rmax; if (d < 0) then d := 0; + + sigma := ArcSin(in_z / r_in) + mul_z * random * d; + phi := ArcTan2(in_y, in_x) + mul_y * random * d; + r := r_in + mul_x * random * d; + + SinCos(sigma, sins, coss); + SinCos(phi, sinp, cosp); + + FPx^ := VVAR * (r * coss * cosp); + FPy^ := VVAR * (r * coss * sinp); + FPz^ := VVAR * (sins); + color^ := Abs(Frac(color^ + mul_c * random * d)); +end; +procedure TVariationPostFalloff2.CalcFunctionGaussian; +var + in_x, in_y, in_z, d: double; + sigma, phi, r, sins, coss, sinp, cosp: double; +begin + in_x := FPx^; + in_y := FPy^; + in_z := FPz^; + + d := sqrt(sqr(in_x - x0) + sqr(in_y - y0) + sqr(in_z - z0)); + if (invert <> 0) then d := 1 - d; if (d < 0) then d := 0; + d := (d - mindist) * rmax; if (d < 0) then d := 0; + + sigma := d * random * 2 * PI; + phi := d * random * PI; + r := d * random; + + SinCos(sigma, sins, coss); + SinCos(phi, sinp, cosp); + + FPx^ := VVAR * (in_x + mul_x * r * coss * cosp); + FPy^ := VVAR * (in_y + mul_y * r * coss * sinp); + FPz^ := VVAR * (in_z + mul_z * r * sins); + color^ := Abs(Frac(color^ + mul_c * random * d)); +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationPostFalloff2.Create; +begin + scatter := 1; + mindist := 0.5; + mul_x := 1; + mul_y := 1; + mul_z := 0; + mul_c := 0; + x0 := 0; + y0 := 0; + z0 := 0; + invert := 0; + blurtype := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPostFalloff2.GetInstance: TBaseVariation; +begin + Result := TVariationPostFalloff2.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPostFalloff2.GetName: string; +begin + Result := 'post_falloff2'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostFalloff2.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := n_scatter; + 1: Result := n_mindist; + 2: Result := n_mul_x; + 3: Result := n_mul_y; + 4: Result := n_mul_z; + 5: Result := n_mul_c; + 6: Result := n_x0; + 7: Result := n_y0; + 8: Result := n_z0; + 9: Result := n_invert; + 10: Result := n_blurtype; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostFalloff2.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = n_scatter then begin + if Value < 1e-6 then Value := 1e-6; + scatter := Value; + Result := True; + end else if Name = n_mindist then begin + if Value < 0 then Value := 0; + mindist := Value; + Result := True; + end else if Name = n_mul_x then begin + if Value < 0 then Value := 0 + else if Value > 1 then Value := 1; + mul_x := Value; + Result := True; + end else if Name = n_mul_y then begin + if Value < 0 then Value := 0 + else if Value > 1 then Value := 1; + mul_y := Value; + Result := True; + end else if Name = n_mul_z then begin + if Value < 0 then Value := 0 + else if Value > 1 then Value := 1; + mul_z := Value; + Result := True; + end else if Name = n_mul_c then begin + if Value < 0 then Value := 0 + else if Value > 1 then Value := 1; + mul_c := Value; + Result := True; + end else if Name = n_x0 then begin + x0 := Value; + Result := True; + end else if Name = n_y0 then begin + y0 := Value; + Result := True; + end else if Name = n_z0 then begin + z0 := Value; + Result := True; + end else if Name = n_invert then begin + if (Value > 1) then Value := 1; + if (Value < 0) then Value := 0; + invert := Round(Value); + Result := True; + end else if Name = n_blurtype then begin + if (Value > 2) then Value := 2; + if (Value < 0) then Value := 0; + blurtype := Round(Value); + Result := True; + end +end; +function TVariationPostFalloff2.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = n_scatter then begin + scatter := 1; + Result := True; + end else if Name = n_mindist then begin + mindist := 0.5; + Result := True; + end else if Name = n_mul_x then begin + mul_x := 1; + Result := True; + end else if Name = n_mul_y then begin + mul_y := 1; + Result := True; + end else if Name = n_mul_z then begin + mul_z := 0; + Result := True; + end else if Name = n_mul_c then begin + mul_c := 0; + Result := True; + end else if Name = n_x0 then begin + x0 := 0; + Result := True; + end else if Name = n_y0 then begin + y0 := 0; + Result := True; + end else if Name = n_z0 then begin + z0 := 0; + Result := True; + end else if Name = n_invert then begin + invert := 0; + Result := True; + end else if Name = n_blurtype then begin + blurtype := 0; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostFalloff2.GetNrVariables: integer; +begin + Result := 11 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPostFalloff2.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = n_scatter then begin + Value := scatter; + Result := True; + end else if Name = n_mindist then begin + Value := mindist; + Result := True; + end else if Name = n_mul_x then begin + Value := mul_x; + Result := True; + end else if Name = n_mul_y then begin + Value := mul_y; + Result := True; + end else if Name = n_mul_z then begin + Value := mul_z; + Result := True; + end else if Name = n_mul_c then begin + Value := mul_c; + Result := True; + end else if Name = n_x0 then begin + Value := x0; + Result := True; + end else if Name = n_y0 then begin + Value := y0; + Result := True; + end else if Name = n_z0 then begin + Value := z0; + Result := True; + end else if Name = n_invert then begin + Value := invert; + Result := True; + end else if Name = n_blurtype then begin + Value := blurtype; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationPostFalloff2), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varPreBwraps.pas b/Source/Variations/varPreBwraps.pas new file mode 100644 index 0000000..f83d8f3 --- /dev/null +++ b/Source/Variations/varPreBwraps.pas @@ -0,0 +1,227 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varPreBwraps; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationPreBwraps = class(TBaseVariation) + private + pre_bwraps_cellsize, pre_bwraps_space, pre_bwraps_gain, + pre_bwraps_inner_twist, pre_bwraps_outer_twist, + g2, r2, rfactor: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationPreBwraps.Prepare; +var + max_bubble, radius: double; +begin + radius := 0.5 * (pre_bwraps_cellsize / (1.0 + sqr(pre_bwraps_space))); + g2 := sqr(pre_bwraps_gain) / (radius + 1e-6) + 1e-6; + max_bubble := g2 * radius; + + if (max_bubble > 2.0) then max_bubble := 1.0 + else max_bubble := max_bubble * (1.0 / (sqr(max_bubble)/4.0 + 1.0)); + + r2 := sqr(radius); + rfactor := radius / max_bubble; +end; + +procedure TVariationPreBwraps.CalcFunction; +var + Vx, Vy, + Cx, Cy, + Lx, Ly, + r, theta, s, c : double; +begin + Vx := FTx^; + Vy := FTy^; + + if (pre_bwraps_cellsize <> 0.0) then + begin + Cx := (floor(Vx / pre_bwraps_cellsize) + 0.5) * pre_bwraps_cellsize; + Cy := (floor(Vy / pre_bwraps_cellsize) + 0.5) * pre_bwraps_cellsize; + + Lx := Vx - Cx; + Ly := Vy - Cy; + + if ((sqr(Lx) + sqr(Ly)) <= r2) then + begin + Lx := Lx * g2; + Ly := Ly * g2; + + r := rfactor / ((sqr(Lx) + sqr(Ly)) / 4.0 + 1); + + Lx := Lx * r; + Ly := Ly * r; + + r := (sqr(Lx) + sqr(Ly)) / r2; + theta := pre_bwraps_inner_twist * (1.0 - r) + pre_bwraps_outer_twist * r; + SinCos(theta, s, c); + + Vx := Cx + c * Lx + s * Ly; + Vy := Cy - s * Lx + c * Ly; + + FTx^ := VVAR * Vx; + FTy^ := VVAR * Vy; + FTz^ := VVAR * FTz^; + end; + end; + +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationPreBwraps.Create; +begin + pre_bwraps_cellsize := 1; + pre_bwraps_space := 0; + pre_bwraps_gain := 1; + pre_bwraps_inner_twist := 0; + pre_bwraps_outer_twist := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPreBwraps.GetInstance: TBaseVariation; +begin + Result := TVariationPreBwraps.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPreBwraps.GetName: string; +begin + Result := 'pre_bwraps'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreBwraps.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'pre_bwraps_cellsize'; + 1: Result := 'pre_bwraps_space'; + 2: Result := 'pre_bwraps_gain'; + 3: Result := 'pre_bwraps_inner_twist'; + 4: Result := 'pre_bwraps_outer_twist'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreBwraps.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'pre_bwraps_cellsize' then begin + pre_bwraps_cellsize := Value; + Result := True; + end else if Name = 'pre_bwraps_space' then begin + pre_bwraps_space := Value; + Result := True; + end else if Name = 'pre_bwraps_gain' then begin + pre_bwraps_gain := Value; + Result := True; + end else if Name = 'pre_bwraps_inner_twist' then begin + pre_bwraps_inner_twist := Value; + Result := True; + end else if Name = 'pre_bwraps_outer_twist' then begin + pre_bwraps_outer_twist := Value; + Result := True; + end +end; +function TVariationPreBwraps.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'pre_bwraps_cellsize' then begin + pre_bwraps_cellsize := 1; + Result := True; + end else if Name = 'pre_bwraps_space' then begin + pre_bwraps_space := 0; + Result := True; + end else if Name = 'pre_bwraps_gain' then begin + pre_bwraps_gain := 1; + Result := True; + end else if Name = 'pre_bwraps_inner_twist' then begin + pre_bwraps_inner_twist := 0; + Result := True; + end else if Name = 'pre_bwraps_outer_twist' then begin + pre_bwraps_outer_twist := 0; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreBwraps.GetNrVariables: integer; +begin + Result := 5 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreBwraps.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'pre_bwraps_cellsize' then begin + if Value = 0 then Value := 1e-6; + Value := pre_bwraps_cellsize; + Result := True; + end else if Name = 'pre_bwraps_space' then begin + Value := pre_bwraps_space; + Result := True; + end else if Name = 'pre_bwraps_gain' then begin + Value := pre_bwraps_gain; + Result := True; + end else if Name = 'pre_bwraps_inner_twist' then begin + Value := pre_bwraps_inner_twist; + Result := True; + end else if Name = 'pre_bwraps_outer_twist' then begin + Value := pre_bwraps_outer_twist; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationPreBwraps), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varPreCrop.pas b/Source/Variations/varPreCrop.pas new file mode 100644 index 0000000..05f3d75 --- /dev/null +++ b/Source/Variations/varPreCrop.pas @@ -0,0 +1,231 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varPreCrop; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationPreCrop = class(TBaseVariation) + const + n_x0 : string = 'pre_crop_left'; + n_y0 : string = 'pre_crop_top'; + n_x1 : string = 'pre_crop_right'; + n_y1 : string = 'pre_crop_bottom'; + n_s : string = 'pre_crop_scatter_area'; + n_z : string = 'pre_crop_zero'; + n : string = 'pre_crop'; + + private + x0, y0, x1, y1, s, w, h: double; + _x0, _y0, _x1, _y1: double; + z: integer; + + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationPreCrop.Prepare; +begin + if (x0 < x1) then begin + _x0 := x0; + _x1 := x1; + end else begin + _x0 := x1; + _x1 := x0; + end; + + if (y0 < y1) then begin + _y0 := y0; + _y1 := y1; + end else begin + _y0 := y1; + _y1 := y0; + end; + + w := (_x1 - _x0) * 0.5 * s; + h := (_y1 - _y0) * 0.5 * s; +end; + +procedure TVariationPreCrop.CalcFunction; +var x, y: double; +begin + x := FTx^; + y := FTy^; + + if ((x < _x0) or (x > _x1) or (y < _y0) or (y > _y1)) and (z <> 0) then begin + x := 0; y := 0; + end else begin + if x < _x0 then x := _x0 + random * w + else if x > _x1 then x := _x1 - random * w; + if y < _y0 then y := _y0 + random * h + else if y > _y1 then y := _y1 - random * h; + end; + + FTx^ := VVAR * x; + FTy^ := VVAR * y; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationPreCrop.Create; +begin + x0 := -1; x1 := 1; + y0 := -1; y1 := 1; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPreCrop.GetInstance: TBaseVariation; +begin + Result := TVariationPreCrop.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPreCrop.GetName: string; +begin + Result := n; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreCrop.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := n_x0; + 1: Result := n_y0; + 2: Result := n_x1; + 3: Result := n_y1; + 4: Result := n_s; + 5: Result := n_z; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreCrop.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = n_x0 then begin + x0 := Value; + Result := True; + end else if Name = n_y0 then begin + y0 := Value; + Result := True; + end else if Name = n_x1 then begin + x1 := Value; + Result := True; + end else if Name = n_y1 then begin + y1 := Value; + Result := True; + end else if Name = n_s then begin + if (Value < -1) then Value := -1; + if (Value > 1) then Value := 1; + s := Value; + Result := True; + end else if Name = n_z then begin + if (Value > 1) then Value := 1; + if (Value < 0) then Value := 0; + z := Round(Value); + Result := True; + end +end; +function TVariationPreCrop.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = n_x0 then begin + x0 := -1; + Result := True; + end else if Name = n_y0 then begin + y0 := -1; + Result := True; + end else if Name = n_x1 then begin + x1 := 1; + Result := True; + end else if Name = n_y1 then begin + y1 := 1; + Result := True; + end else if Name = n_s then begin + s := 0; + Result := True; + end else if Name = n_z then begin + z := 0; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreCrop.GetNrVariables: integer; +begin + Result := 6 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreCrop.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = n_x0 then begin + Value := x0; + Result := True; + end else if Name = n_y0 then begin + Value := y0; + Result := True; + end else if Name = n_x1 then begin + Value := x1; + Result := True; + end else if Name = n_y1 then begin + Value := y1; + Result := True; + end else if Name = n_s then begin + Value := s; + Result := True; + end else if Name = n_z then begin + Value := z; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationPreCrop), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varPreDisc.pas b/Source/Variations/varPreDisc.pas new file mode 100644 index 0000000..62d2f32 --- /dev/null +++ b/Source/Variations/varPreDisc.pas @@ -0,0 +1,119 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varPreDisc; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationPreDisc = class(TBaseVariation) + private + vvar_by_pi: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +{ TVariationPreSpherical } + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationPreDisc.Prepare; +begin + vvar_by_pi := vvar / PI; +end; + +procedure TVariationPreDisc.CalcFunction; +var + r, sinr, cosr: double; +begin + SinCos(PI * sqrt(sqr(FTx^) + sqr(FTy^)), sinr, cosr); + r := vvar_by_pi * arctan2(FTx^, FTy^); + FTx^ := sinr * r; + FTy^ := cosr * r; + FTz^ := VVAR * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationPreDisc.Create; +begin +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPreDisc.GetInstance: TBaseVariation; +begin + Result := TVariationPreDisc.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPreDisc.GetName: string; +begin + Result := 'pre_disc'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreDisc.GetVariableNameAt(const Index: integer): string; +begin + Result := ''; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreDisc.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreDisc.GetNrVariables: integer; +begin + Result := 0 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreDisc.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationPreDisc), true, false); +end. diff --git a/Source/Variations/varPreFalloff2.pas b/Source/Variations/varPreFalloff2.pas new file mode 100644 index 0000000..2cdcb55 --- /dev/null +++ b/Source/Variations/varPreFalloff2.pas @@ -0,0 +1,348 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varPreFalloff2; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationPreFalloff2 = class(TBaseVariation) + const + n_scatter : string = 'pre_falloff2_scatter'; + n_mindist : string = 'pre_falloff2_mindist'; + n_mul_x : string = 'pre_falloff2_mul_x'; + n_mul_y : string = 'pre_falloff2_mul_y'; + n_mul_z : string = 'pre_falloff2_mul_z'; + n_mul_c : string = 'pre_falloff2_mul_c'; + n_x0 : string = 'pre_falloff2_x0'; + n_y0 : string = 'pre_falloff2_y0'; + n_z0 : string = 'pre_falloff2_z0'; + n_invert : string = 'pre_falloff2_invert'; + n_blurtype : string = 'pre_falloff2_type'; + + private + rmax: double; + x0, y0, z0: double; + scatter, mindist: double; + invert, blurtype: integer; + mul_x, mul_y, mul_z, mul_c: double; + + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + procedure CalcFunctionRadial; + procedure CalcFunctionGaussian; + procedure GetCalcFunction(var f: TCalcFunction); override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationPreFalloff2.Prepare; +begin + rmax := 0.04 * scatter; +end; + +procedure TVariationPreFalloff2.GetCalcFunction(var f: TCalcFunction); +begin + if blurtype = 1 then f := CalcFunctionRadial + else if blurtype = 2 then f := CalcFunctionGaussian + else f := CalcFunction; +end; +procedure TVariationPreFalloff2.CalcFunction; +var + in_x, in_y, in_z, d: double; +begin + in_x := FTx^; + in_y := FTy^; + in_z := FTz^; + + d := sqrt(sqr(in_x - x0) + sqr(in_y - y0) + sqr(in_z - z0)); + if (invert <> 0) then d := 1 - d; if (d < 0) then d := 0; + d := (d - mindist) * rmax; if (d < 0) then d := 0; + + FTx^ := VVAR * (in_x + mul_x * random * d); + FTy^ := VVAR * (in_y + mul_y * random * d); + FTz^ := VVAR * (in_z + mul_z * random * d); + color^ := Abs(Frac(color^ + mul_c * random * d)); +end; +procedure TVariationPreFalloff2.CalcFunctionRadial; +var + in_x, in_y, in_z, d, r_in: double; + sigma, phi, r, sins, coss, sinp, cosp: double; +begin + in_x := FTx^; + in_y := FTy^; + in_z := FTz^; + + r_in := sqrt(sqr(in_x) + sqr(in_y) + sqr(in_z)) + 1e-6; + d := sqrt(sqr(in_x - x0) + sqr(in_y - y0) + sqr(in_z - z0)); + if (invert <> 0) then d := 1 - d; if (d < 0) then d := 0; + d := (d - mindist) * rmax; if (d < 0) then d := 0; + + sigma := ArcSin(in_z / r_in) + mul_z * random * d; + phi := ArcTan2(in_y, in_x) + mul_y * random * d; + r := r_in + mul_x * random * d; + + SinCos(sigma, sins, coss); + SinCos(phi, sinp, cosp); + + FTx^ := VVAR * (r * coss * cosp); + FTy^ := VVAR * (r * coss * sinp); + FTz^ := VVAR * (sins); + color^ := Abs(Frac(color^ + mul_c * random * d)); +end; +procedure TVariationPreFalloff2.CalcFunctionGaussian; +var + in_x, in_y, in_z, d: double; + sigma, phi, r, sins, coss, sinp, cosp: double; +begin + in_x := FTx^; + in_y := FTy^; + in_z := FTz^; + + d := sqrt(sqr(in_x - x0) + sqr(in_y - y0) + sqr(in_z - z0)); + if (invert <> 0) then d := 1 - d; if (d < 0) then d := 0; + d := (d - mindist) * rmax; if (d < 0) then d := 0; + + sigma := d * random * 2 * PI; + phi := d * random * PI; + r := d * random; + + SinCos(sigma, sins, coss); + SinCos(phi, sinp, cosp); + + FTx^ := VVAR * (in_x + mul_x * r * coss * cosp); + FTy^ := VVAR * (in_y + mul_y * r * coss * sinp); + FTz^ := VVAR * (in_z + mul_z * r * sins); + color^ := Abs(Frac(color^ + mul_c * random * d)); +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationPreFalloff2.Create; +begin + scatter := 1; + mindist := 0.5; + mul_x := 1; + mul_y := 1; + mul_z := 0; + mul_c := 0; + x0 := 0; + y0 := 0; + z0 := 0; + invert := 0; + blurtype := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPreFalloff2.GetInstance: TBaseVariation; +begin + Result := TVariationPreFalloff2.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPreFalloff2.GetName: string; +begin + Result := 'pre_falloff2'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreFalloff2.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := n_scatter; + 1: Result := n_mindist; + 2: Result := n_mul_x; + 3: Result := n_mul_y; + 4: Result := n_mul_z; + 5: Result := n_mul_c; + 6: Result := n_x0; + 7: Result := n_y0; + 8: Result := n_z0; + 9: Result := n_invert; + 10: Result := n_blurtype; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreFalloff2.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = n_scatter then begin + if Value < 1e-6 then Value := 1e-6; + scatter := Value; + Result := True; + end else if Name = n_mindist then begin + if Value < 0 then Value := 0; + mindist := Value; + Result := True; + end else if Name = n_mul_x then begin + if Value < 0 then Value := 0 + else if Value > 1 then Value := 1; + mul_x := Value; + Result := True; + end else if Name = n_mul_y then begin + if Value < 0 then Value := 0 + else if Value > 1 then Value := 1; + mul_y := Value; + Result := True; + end else if Name = n_mul_z then begin + if Value < 0 then Value := 0 + else if Value > 1 then Value := 1; + mul_z := Value; + Result := True; + end else if Name = n_mul_c then begin + if Value < 0 then Value := 0 + else if Value > 1 then Value := 1; + mul_c := Value; + Result := True; + end else if Name = n_x0 then begin + x0 := Value; + Result := True; + end else if Name = n_y0 then begin + y0 := Value; + Result := True; + end else if Name = n_z0 then begin + z0 := Value; + Result := True; + end else if Name = n_invert then begin + if (Value > 1) then Value := 1; + if (Value < 0) then Value := 0; + invert := Round(Value); + Result := True; + end else if Name = n_blurtype then begin + if (Value > 2) then Value := 2; + if (Value < 0) then Value := 0; + blurtype := Round(Value); + Result := True; + end +end; +function TVariationPreFalloff2.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = n_scatter then begin + scatter := 1; + Result := True; + end else if Name = n_mindist then begin + mindist := 0.5; + Result := True; + end else if Name = n_mul_x then begin + mul_x := 1; + Result := True; + end else if Name = n_mul_y then begin + mul_y := 1; + Result := True; + end else if Name = n_mul_z then begin + mul_z := 0; + Result := True; + end else if Name = n_mul_c then begin + mul_c := 0; + Result := True; + end else if Name = n_x0 then begin + x0 := 0; + Result := True; + end else if Name = n_y0 then begin + y0 := 0; + Result := True; + end else if Name = n_z0 then begin + z0 := 0; + Result := True; + end else if Name = n_invert then begin + invert := 0; + Result := True; + end else if Name = n_blurtype then begin + blurtype := 0; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreFalloff2.GetNrVariables: integer; +begin + Result := 11 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreFalloff2.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = n_scatter then begin + Value := scatter; + Result := True; + end else if Name = n_mindist then begin + Value := mindist; + Result := True; + end else if Name = n_mul_x then begin + Value := mul_x; + Result := True; + end else if Name = n_mul_y then begin + Value := mul_y; + Result := True; + end else if Name = n_mul_z then begin + Value := mul_z; + Result := True; + end else if Name = n_mul_c then begin + Value := mul_c; + Result := True; + end else if Name = n_x0 then begin + Value := x0; + Result := True; + end else if Name = n_y0 then begin + Value := y0; + Result := True; + end else if Name = n_z0 then begin + Value := z0; + Result := True; + end else if Name = n_invert then begin + Value := invert; + Result := True; + end else if Name = n_blurtype then begin + Value := blurtype; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationPreFalloff2), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varPreSinusoidal.pas b/Source/Variations/varPreSinusoidal.pas new file mode 100644 index 0000000..ad3dc9f --- /dev/null +++ b/Source/Variations/varPreSinusoidal.pas @@ -0,0 +1,107 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varPreSinusoidal; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationPreSinusoidal = class(TBaseVariation) + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +{ TVariationPreSpherical } + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationPreSinusoidal.CalcFunction; +begin + FTx^ := vvar * sin(FTx^); + FTy^ := vvar * sin(FTy^); + FTz^ := VVAR * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationPreSinusoidal.Create; +begin +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPreSinusoidal.GetInstance: TBaseVariation; +begin + Result := TVariationPreSinusoidal.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPreSinusoidal.GetName: string; +begin + Result := 'pre_sinusoidal'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreSinusoidal.GetVariableNameAt(const Index: integer): string; +begin + Result := ''; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreSinusoidal.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreSinusoidal.GetNrVariables: integer; +begin + Result := 0 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreSinusoidal.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationPreSinusoidal), true, false); +end. diff --git a/Source/Variations/varPreSpherical.pas b/Source/Variations/varPreSpherical.pas new file mode 100644 index 0000000..727384e --- /dev/null +++ b/Source/Variations/varPreSpherical.pas @@ -0,0 +1,110 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varPreSpherical; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationPreSpherical = class(TBaseVariation) + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + + + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +{ TVariationPreSpherical } + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationPreSpherical.CalcFunction; +var r: double; +begin + r := vvar / (sqr(FTx^) + sqr(FTy^) + 10e-6); + FTx^ := FTx^ * r; + FTy^ := FTy^ * r; + FTz^ := VVAR * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationPreSpherical.Create; +begin +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPreSpherical.GetInstance: TBaseVariation; +begin + Result := TVariationPreSpherical.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationPreSpherical.GetName: string; +begin + Result := 'pre_spherical'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreSpherical.GetVariableNameAt(const Index: integer): string; +begin + Result := ''; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreSpherical.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreSpherical.GetNrVariables: integer; +begin + Result := 0 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationPreSpherical.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationPreSpherical), true, false); +end. diff --git a/Source/Variations/varRadialBlur.pas b/Source/Variations/varRadialBlur.pas index d437e0f..da2bebb 100644 --- a/Source/Variations/varRadialBlur.pas +++ b/Source/Variations/varRadialBlur.pas @@ -26,13 +26,16 @@ interface uses - BaseVariation, XFormMan, AsmRandom; + BaseVariation, XFormMan; const var_name = 'radial_blur'; var_a_name = 'radial_blur_angle'; -{$define _ASM_} +{$ifdef Apo7X64} +{$else} + {$define _ASM_} +{$endif} type TVariationRadialBlur = class(TBaseVariation) @@ -99,7 +102,6 @@ procedure TVariationRadialBlur.GetCalcFunction(var f: TCalcFunction); /////////////////////////////////////////////////////////////////////////////// procedure TVariationRadialBlur.CalcFunction; -{$ifndef _ASM_} var rndG, rz, ra: double; sina, cosa: extended; @@ -114,66 +116,11 @@ procedure TVariationRadialBlur.CalcFunction; FPx^ := FPx^ + ra * cosa + rz * FTx^; FPy^ := FPy^ + ra * sina + rz * FTy^; -{$else} -asm - mov edx, [eax + FTx] - fld qword ptr [edx + 8] // FTy - fld qword ptr [edx] // FTx - - fld st(1) - fmul st, st - fld st(1) - fmul st, st - faddp - fsqrt - - fld st(2) - fld st(2) - fpatan - - fld qword ptr [eax + rnd] - fadd qword ptr [eax + rnd+8] - fadd qword ptr [eax + rnd+16] - fadd qword ptr [eax + rnd+24] - fld1 - fsub st(1), st - fsub st(1), st - - fld st(1) - fmul qword ptr [eax + zoom_var] - fsubrp - - fmul st(4), st - fmulp st(5), st - - fmul qword ptr [eax + spin_var] - faddp - - call AsmRandExt - mov edx, [eax + N] - fstp qword ptr [eax + rnd + edx*8] - inc edx - and edx,$03 - mov [eax + N], edx - - fsincos - - fmul st, st(2) - faddp st(3), st - fmulp - faddp st(2), st - mov edx, [eax + FPx] - fadd qword ptr [edx] - fstp qword ptr [edx] - fadd qword ptr [edx + 8] - fstp qword ptr [edx + 8] - fwait -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; /////////////////////////////////////////////////////////////////////////////// procedure TVariationRadialBlur.CalcZoom; -{$ifndef _ASM_} var r: double; begin @@ -184,44 +131,11 @@ procedure TVariationRadialBlur.CalcZoom; FPx^ := FPx^ + r * FTx^; FPy^ := FPy^ + r * FTy^; -{$else} -asm - fld qword ptr [eax + rnd] - fadd qword ptr [eax + rnd+8] - fadd qword ptr [eax + rnd+16] - fadd qword ptr [eax + rnd+24] - fld1 - fadd st, st - fsubp st(1), st - fmul qword ptr [eax + zoom_var] - - call AsmRandExt - mov edx, [eax + N] - fstp qword ptr [eax + rnd + edx*8] - inc edx - and edx,$03 - mov [eax + N], edx - - mov edx, [eax + FTx] - fld qword ptr [edx + 8] // FTy -// mov ecx, [eax + FTx] - fld qword ptr [edx] - - fmul st, st(2) -// mov edx, [eax + FPx] - fadd qword ptr [edx + 16] - fstp qword ptr [edx + 16] - fmulp -// mov edx, [eax + FPy] - fadd qword ptr [edx + 24] - fstp qword ptr [edx + 24] - fwait -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; /////////////////////////////////////////////////////////////////////////////// procedure TVariationRadialBlur.CalcSpin; -{$ifndef _ASM_} var r: double; sina, cosa: extended; @@ -235,54 +149,7 @@ procedure TVariationRadialBlur.CalcSpin; FPx^ := FPx^ + r * cosa - FTx^; FPy^ := FPy^ + r * sina - FTy^; -{$else} -asm - mov edx, [eax + FTx] -// mov edx, [eax + FTy] - fld qword ptr [edx + 8] -// mov edx, [eax + FTx] - fld qword ptr [edx] - fld st(1) - fld st(1) - fpatan - - fld qword ptr [eax + rnd] - fadd qword ptr [eax + rnd+8] - fadd qword ptr [eax + rnd+16] - fadd qword ptr [eax + rnd+24] - fld1 - fadd st, st - fsubp st(1), st - fmul qword ptr [eax + spin_var] - - call AsmRandExt - mov edx, [eax + N] - fstp qword ptr [eax + rnd + edx*8] - inc edx - and edx,$03 - mov [eax + N], edx - - faddp - fsincos - - fld st(3) - fmul st,st - fld st(3) - fmul st,st - faddp - fsqrt - fmul st(2), st - fmulp st(1), st - mov edx, [eax + FPx] - fadd qword ptr [edx] - fsubrp st(2),st -// mov edx, [eax + FPy] - fadd qword ptr [edx + 8] - fsubrp st(2), st - fstp qword ptr [edx] - fstp qword ptr [edx + 8] - fwait -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; /////////////////////////////////////////////////////////////////////////////// @@ -344,5 +211,5 @@ function TVariationRadialBlur.GetNrVariables: integer; /////////////////////////////////////////////////////////////////////////////// initialization - RegisterVariation(TVariationClassLoader.Create(TVariationRadialBlur), false, false); + RegisterVariation(TVariationClassLoader.Create(TVariationRadialBlur), true, false); end. diff --git a/Source/Variations/varRectangles.pas b/Source/Variations/varRectangles.pas index 0ce9186..54064f2 100644 --- a/Source/Variations/varRectangles.pas +++ b/Source/Variations/varRectangles.pas @@ -81,24 +81,28 @@ procedure TVariationRectangles.CalcFunction; begin FPx^ := FPx^ + vvar * ((2*floor(FTx^/FRectanglesX) + 1)*FRectanglesX - FTx^); FPy^ := FPy^ + vvar * ((2*floor(FTy^/FRectanglesY) + 1)*FRectanglesY - FTy^); + FPz^ := FPz^ + vvar * FTz^; end; procedure TVariationRectangles.CalcZeroX; begin FPx^ := FPx^ + vvar * FTx^; FPy^ := FPy^ + vvar * ((2*floor(FTy^/FRectanglesY) + 1)*FRectanglesY - FTy^); + FPz^ := FPz^ + vvar * FTz^; end; procedure TVariationRectangles.CalcZeroY; begin FPx^ := FPx^ + vvar * ((2*floor(FTx^/FRectanglesX) + 1)*FRectanglesX - FTx^); FPy^ := FPy^ + vvar * FTy^; + FPz^ := FPz^ + vvar * FTz^; end; procedure TVariationRectangles.CalcZeroXY; begin FPx^ := FPx^ + vvar * FTx^; FPy^ := FPy^ + vvar * FTy^; + FPz^ := FPz^ + vvar * FTz^; end; /////////////////////////////////////////////////////////////////////////////// @@ -167,5 +171,5 @@ class function TVariationRectangles.GetInstance: TBaseVariation; /////////////////////////////////////////////////////////////////////////////// initialization - RegisterVariation(TVariationClassLoader.Create(TVariationRectangles), false, false); + RegisterVariation(TVariationClassLoader.Create(TVariationRectangles), true, false); end. diff --git a/Source/Variations/varRings2.pas b/Source/Variations/varRings2.pas index 5046d89..32acb6b 100644 --- a/Source/Variations/varRings2.pas +++ b/Source/Variations/varRings2.pas @@ -84,6 +84,7 @@ procedure TVariationRings2.CalcFunction; FPx^ := FPx^ + r * FTx^; FPy^ := FPy^ + r * FTy^; + FPz^ := FPz^ + vvar * FTz^; end; /////////////////////////////////////////////////////////////////////////////// @@ -142,5 +143,5 @@ function TVariationRings2.GetVariable(const Name: string; var value: double): bo /////////////////////////////////////////////////////////////////////////////// initialization - RegisterVariation(TVariationClassLoader.Create(TVariationRings2), false, false); + RegisterVariation(TVariationClassLoader.Create(TVariationRings2), true, false); end. diff --git a/Source/Variations/varScry.pas b/Source/Variations/varScry.pas new file mode 100644 index 0000000..1add6f8 --- /dev/null +++ b/Source/Variations/varScry.pas @@ -0,0 +1,127 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varScry; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationScry = class(TBaseVariation) + private + v: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationScry.Prepare; +begin + if (VVAR = 0) then + v := 1.0 / 1e-6 + else v := 1.0 / vvar; +end; + +procedure TVariationScry.CalcFunction; +var t, r : double; +begin + t := sqr(FTx^) + sqr(FTy^); + r := 1.0 / (sqrt(t) * (t + v)); + + FPx^ := FPx^ + FTx^ * r; + FPy^ := FPy^ + FTy^ * r; + + FPz^ := FPz^ + vvar * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationScry.Create; +begin + v := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationScry.GetInstance: TBaseVariation; +begin + Result := TVariationScry.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationScry.GetName: string; +begin + Result := 'scry'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationScry.GetVariableNameAt(const Index: integer): string; +begin + Result := ''; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationScry.SetVariable(const Name: string; var value: double): boolean; +var temp: double; +begin + Result := False; +end; +function TVariationScry.ResetVariable(const Name: string): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationScry.GetNrVariables: integer; +begin + Result := 0 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationScry.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationScry), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varSeparation.pas b/Source/Variations/varSeparation.pas new file mode 100644 index 0000000..4b32ce2 --- /dev/null +++ b/Source/Variations/varSeparation.pas @@ -0,0 +1,175 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varSeparation; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationSeparation = class(TBaseVariation) + private + separation_x, separation_y: double; + separation_xinside, separation_yinside: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationSeparation.Prepare; +begin +end; + +procedure TVariationSeparation.CalcFunction; +begin + if(FTx^ > 0.0) then + FPx^ := FPx^ + VVAR * (sqrt(sqr(FTx^) + sqr(separation_x))- FTx^ * (separation_xinside)) + else + FPx^ := FPx^ - VVAR * (sqrt(sqr(FTx^) + sqr(separation_x))+ FTx^ * (separation_xinside)) ; + if(FTy^ > 0.0) then + FPy^ := FPy^ + VVAR * (sqrt(sqr(FTy^) + sqr(separation_y))- FTy^ * (separation_yinside)) + else + FPy^ := FPy^ - VVAR * (sqrt(sqr(FTy^) + sqr(separation_y))+ FTy^ * (separation_yinside)) ; + + FPz^ := FPz^ + vvar * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationSeparation.Create; +begin + separation_x := 1; + separation_y := 1; + separation_xinside := 0; + separation_yinside := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationSeparation.GetInstance: TBaseVariation; +begin + Result := TVariationSeparation.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationSeparation.GetName: string; +begin + Result := 'separation'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationSeparation.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'separation_x'; + 1: Result := 'separation_y'; + 2: Result := 'separation_xinside'; + 3: Result := 'separation_yinside'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationSeparation.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'separation_x' then begin + separation_x := Value; + Result := True; + end else if Name = 'separation_y' then begin + separation_y := Value; + Result := True; + end else if Name = 'separation_xinside' then begin + separation_xinside := Value; + Result := True; + end else if Name = 'separation_yinside' then begin + separation_yinside := Value; + Result := True; + end +end; +function TVariationSeparation.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'separation_x' then begin + separation_x := 1; + Result := True; + end else if Name = 'separation_y' then begin + separation_y := 1; + Result := True; + end else if Name = 'separation_xinside' then begin + separation_xinside := 0; + Result := True; + end else if Name = 'separation_yinside' then begin + separation_yinside := 0; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationSeparation.GetNrVariables: integer; +begin + Result := 4 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationSeparation.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'separation_x' then begin + Value := separation_x; + Result := True; + end else if Name = 'separation_y' then begin + Value := separation_y; + Result := True; + end else if Name = 'separation_xinside' then begin + Value := separation_xinside; + Result := True; + end else if Name = 'separation_yinside' then begin + Value := separation_yinside; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationSeparation), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varSplits.pas b/Source/Variations/varSplits.pas new file mode 100644 index 0000000..df6f092 --- /dev/null +++ b/Source/Variations/varSplits.pas @@ -0,0 +1,141 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varSplits; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationSplits = class(TBaseVariation) + private + splits_x, splits_y: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationSplits.Prepare; +begin +end; + +procedure TVariationSplits.CalcFunction; +begin + if(FTx^ >= 0.0) then + FPx^ := FPx^ + VVAR * (FTx^ + splits_x) + else + FPx^ := FPx^ + VVAR * (FTx^ - splits_x); + + if(FTy^ >= 0.0) then + FPy^ := FPy^ + VVAR * (FTy^ + splits_y) + else + FPy^ := FPy^ + VVAR * (FTy^ - splits_y); + + FPz^ := FPz^ + vvar * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationSplits.Create; +begin + splits_x := 0; + splits_y := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationSplits.GetInstance: TBaseVariation; +begin + Result := TVariationSplits.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationSplits.GetName: string; +begin + Result := 'splits'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationSplits.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'splits_x'; + 1: Result := 'splits_y'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationSplits.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'splits_x' then begin + splits_x := Value; + Result := True; + end else if Name = 'splits_y' then begin + splits_y := Value; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationSplits.GetNrVariables: integer; +begin + Result := 2 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationSplits.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'splits_x' then begin + Value := splits_x; + Result := True; + end else if Name = 'splits_y' then begin + Value := splits_y; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationSplits), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varWaves2.pas b/Source/Variations/varWaves2.pas new file mode 100644 index 0000000..fa74a64 --- /dev/null +++ b/Source/Variations/varWaves2.pas @@ -0,0 +1,188 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varWaves2; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationWaves2 = class(TBaseVariation) + private + waves2_freqx, waves2_freqy, waves2_freqz: double; + waves2_scalex, waves2_scaley, waves2_scalez: double; + + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationWaves2.Prepare; +begin +end; + +procedure TVariationWaves2.CalcFunction; +begin + FPx^ := FPx^ + VVAR * (FTx^ + waves2_scalex * sin(FTy^ * waves2_freqx)); + FPy^ := FPy^ + VVAR * (FTy^ + waves2_scaley * sin(FTx^ * waves2_freqy)); + FPz^ := FPz^ + VVAR * (FTz^ + waves2_scalez * sin(sqrt(sqr(FTx^)+sqr(FTy^)) * waves2_freqz)); +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationWaves2.Create; +begin + waves2_freqx := 2; waves2_scalex := 1; + waves2_freqy := 2; waves2_scaley := 1; + waves2_freqz := 0; waves2_scalez := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationWaves2.GetInstance: TBaseVariation; +begin + Result := TVariationWaves2.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationWaves2.GetName: string; +begin + Result := 'waves2'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationWaves2.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'waves2_freqx'; + 1: Result := 'waves2_freqy'; + 2: Result := 'waves2_freqz'; + 3: Result := 'waves2_scalex'; + 4: Result := 'waves2_scaley'; + 5: Result := 'waves2_scalez'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationWaves2.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'waves2_freqx' then begin + waves2_freqx := Value; + Result := True; + end else if Name = 'waves2_freqy' then begin + waves2_freqy := Value; + Result := True; + end else if Name = 'waves2_freqz' then begin + waves2_freqz := Value; + Result := True; + end else if Name = 'waves2_scalex' then begin + waves2_scalex := Value; + Result := True; + end else if Name = 'waves2_scaley' then begin + waves2_scaley := Value; + Result := True; + end else if Name = 'waves2_scalez' then begin + waves2_scalez := Value; + Result := True; + end +end; +function TVariationWaves2.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'waves2_freqx' then begin + waves2_freqx := 2; + Result := True; + end else if Name = 'waves2_freqy' then begin + waves2_freqy := 2; + Result := True; + end else if Name = 'waves2_freqz' then begin + waves2_freqz := 0; + Result := True; + end else if Name = 'waves2_scalex' then begin + waves2_scalex := 1; + Result := True; + end else if Name = 'waves2_scaley' then begin + waves2_scaley := 1; + Result := True; + end else if Name = 'waves2_scalez' then begin + waves2_scalez := 0; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationWaves2.GetNrVariables: integer; +begin + Result := 6 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationWaves2.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'waves2_freqx' then begin + Value := waves2_freqx; + Result := True; + end else if Name = 'waves2_freqy' then begin + Value := waves2_freqy; + Result := True; + end else if Name = 'waves2_freqz' then begin + Value := waves2_freqz; + Result := True; + end else if Name = 'waves2_scalex' then begin + Value := waves2_scalex; + Result := True; + end else if Name = 'waves2_scaley' then begin + Value := waves2_scaley; + Result := True; + end else if Name = 'waves2_scalez' then begin + Value := waves2_scalez; + Result := True; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationWaves2), true, false); +end. \ No newline at end of file diff --git a/Source/Variations/varWedge.pas b/Source/Variations/varWedge.pas new file mode 100644 index 0000000..0819e60 --- /dev/null +++ b/Source/Variations/varWedge.pas @@ -0,0 +1,183 @@ +{ + Apophysis Copyright (C) 2001-2004 Mark Townsend + Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov + Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov + + Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov + Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + You should have received a copy of the GNU General Public License + GNU General Public License for more details. + + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +} + +unit varWedge; + +interface + +uses + BaseVariation, XFormMan; + +type + TVariationWedge = class(TBaseVariation) + private + wedge_angle, wedge_hole, wedge_swirl: double; + wedge_count : integer; + C1_2PI, comp_fac: double; + public + constructor Create; + + class function GetName: string; override; + class function GetInstance: TBaseVariation; override; + + function GetNrVariables: integer; override; + function GetVariableNameAt(const Index: integer): string; override; + + function SetVariable(const Name: string; var value: double): boolean; override; + function GetVariable(const Name: string; var value: double): boolean; override; + function ResetVariable(const Name: string): boolean; override; + + procedure Prepare; override; + procedure CalcFunction; override; + end; + +implementation + +uses + Math; + +/////////////////////////////////////////////////////////////////////////////// +procedure TVariationWedge.Prepare; +begin + C1_2PI := 0.15915494309189533576888376337251; + comp_fac := 1.0 - wedge_angle * wedge_count * C1_2PI; +end; +procedure TVariationWedge.CalcFunction; +var + r, a, cosa, sina: double; + c: integer; +begin + + r := sqrt(sqr(FTx^) + sqr(FTy^)); + a := ArcTan2(FTy^, FTx^) + wedge_swirl * r; + c := floor((wedge_count * a + PI) * C1_2PI); + a := a * comp_fac + c * wedge_angle; + SinCos(a, sina, cosa); + + r := vvar * (r + wedge_hole); + FPx^ := FPx^ + r * cosa; + FPy^ := FPy^ + r * sina; + FPz^ := FPz^ + VVAR * FTz^; +end; + +/////////////////////////////////////////////////////////////////////////////// +constructor TVariationWedge.Create; +begin + wedge_angle := PI / 2.0; + wedge_hole := 0; + wedge_count := 2; + wedge_swirl := 0; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationWedge.GetInstance: TBaseVariation; +begin + Result := TVariationWedge.Create; +end; + +/////////////////////////////////////////////////////////////////////////////// +class function TVariationWedge.GetName: string; +begin + Result := 'wedge'; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationWedge.GetVariableNameAt(const Index: integer): string; +begin + case Index Of + 0: Result := 'wedge_angle'; + 1: Result := 'wedge_hole'; + 2: Result := 'wedge_count'; + 3: Result := 'wedge_swirl'; + else + Result := ''; + end +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationWedge.SetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'wedge_angle' then begin + wedge_angle := Value; + Result := True; + end else if Name = 'wedge_hole' then begin + wedge_hole := Value; + Result := True; + end else if Name = 'wedge_count' then begin + if (Value < 1) then Value := 1; + Value := Round(value); + wedge_count := Round(Value); + Result := True; + end else if Name = 'wedge_swirl' then begin + wedge_swirl := Value; + Result := True; + end; +end; +function TVariationWedge.ResetVariable(const Name: string): boolean; +begin + Result := False; + if Name = 'wedge_angle' then begin + wedge_angle := PI / 2; + Result := True; + end else if Name = 'wedge_hole' then begin + wedge_hole := 0; + Result := True; + end else if Name = 'wedge_count' then begin + wedge_count := 2; + Result := True; + end else if Name = 'wedge_swirl' then begin + wedge_swirl := 0; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationWedge.GetNrVariables: integer; +begin + Result := 4 +end; + +/////////////////////////////////////////////////////////////////////////////// +function TVariationWedge.GetVariable(const Name: string; var value: double): boolean; +begin + Result := False; + if Name = 'wedge_angle' then begin + Value := wedge_angle; + Result := True; + end else if Name = 'wedge_hole' then begin + Value := wedge_hole; + Result := True; + end else if Name = 'wedge_count' then begin + Value := wedge_count; + Result := True; + end else if Name = 'wedge_swirl' then begin + Value := wedge_swirl; + Result := True; + end; +end; + +/////////////////////////////////////////////////////////////////////////////// +initialization + RegisterVariation(TVariationClassLoader.Create(TVariationWedge), true, false); +end. diff --git a/Source/Variations/varpdj.pas b/Source/Variations/varpdj.pas index 5780872..5b8cf27 100644 --- a/Source/Variations/varpdj.pas +++ b/Source/Variations/varpdj.pas @@ -59,38 +59,10 @@ implementation /////////////////////////////////////////////////////////////////////////////// procedure TVariationPDJ.CalcFunction; -{$ifndef _ASM_} begin FPx^ := FPx^ + vvar * (sin(FA * FTy^) - cos(FB * FTx^)); FPy^ := FPy^ + vvar * (sin(FC * FTx^) - cos(FD * FTy^)); -{$else} -asm - fld qword ptr [eax + vvar] - mov edx, [eax + FTx] - fld qword ptr [edx + 8] // FTy - fld qword ptr [edx] // FTx - - fld st(1) - fmul qword ptr [eax + Fa] - fsin - fld st(1) - fmul qword ptr [eax + Fb] - fcos - fsubp st(1), st - fmul st, st(3) - fadd qword ptr [edx + 16] // FPx - fstp qword ptr [edx + 16] - - fmul qword ptr [eax + Fc] - fsin - fxch st(1) - fmul qword ptr [eax + Fd] - fcos - fsubp st(1), st - fmulp - fadd qword ptr [edx + 24] // FPy - fstp qword ptr [edx + 24] -{$endif} + FPz^ := FPz^ + vvar * FTz^; end; /////////////////////////////////////////////////////////////////////////////// @@ -173,5 +145,5 @@ function TVariationPDJ.GetVariable(const Name: string; var value: double): boole /////////////////////////////////////////////////////////////////////////////// initialization - RegisterVariation(TVariationClassLoader.Create(TVariationPDJ), false, false); + RegisterVariation(TVariationClassLoader.Create(TVariationPDJ), true, false); end. diff --git a/Source/Windows7/DelphiVersions.inc b/Source/Windows7/DelphiVersions.inc new file mode 100644 index 0000000..85b19e7 --- /dev/null +++ b/Source/Windows7/DelphiVersions.inc @@ -0,0 +1,34 @@ +{$IFDEF VER150} + {$DEFINE Delphi7} + {$DEFINE Delphi7_UP} +{$ENDIF} + +{$IFDEF VER170} + {$DEFINE Delphi2005} + {$DEFINE Delphi7_UP} + {$DEFINE Delphi2005_UP} +{$ENDIF} + +{$IFDEF VER180} + {$DEFINE Delphi2006} + {$DEFINE Delphi7_UP} + {$DEFINE Delphi2005_UP} + {$DEFINE Delphi2006_UP} +{$ENDIF} + +{$IFDEF VER185} + {$DEFINE Delphi2007} + {$DEFINE Delphi7_UP} + {$DEFINE Delphi2005_UP} + {$DEFINE Delphi2006_UP} + {$DEFINE Delphi2007_UP} +{$ENDIF} + +{$IFDEF VER200} + {$DEFINE Delphi2009} + {$DEFINE Delphi7_UP} + {$DEFINE Delphi2005_UP} + {$DEFINE Delphi2006_UP} + {$DEFINE Delphi2007_UP} + {$DEFINE Delphi2009_UP} +{$ENDIF} diff --git a/Source/Windows7/dwCustomDestinationList.pas b/Source/Windows7/dwCustomDestinationList.pas new file mode 100644 index 0000000..c27ebb1 --- /dev/null +++ b/Source/Windows7/dwCustomDestinationList.pas @@ -0,0 +1,32 @@ +unit dwCustomDestinationList; + +interface + +uses + Windows, + dwObjectArray; + +const + CLSID_CustomDestinationList: TGUID = '{77f10cf0-3db5-4966-b520-b7c54fd35ed6}'; + +const + KDC_FREQUENT = $01; + KDC_RECENT = $02; + +type + ICustomDestinationList = interface + ['{6332debf-87b5-4670-90c0-5e57b408a49e}'] + procedure SetAppID(pszAppID: LPWSTR); safecall; + function BeginList(out pcMaxSlots: UINT; riid: PGUID): IObjectArray; safecall; + procedure AppendCategory(pszCategory: LPWSTR; poa: IObjectArray); safecall; + procedure AppendKnownCategory(Category: Integer); safecall; + procedure AddUserTasks(poa: IUnknown); safecall; + procedure CommitList(); safecall; + function GetRemovedDestinations(riid: PGUID): IUnknown; safecall; + procedure DeleteList(pszAppID:LPWSTR); safecall; + procedure AbortList(); safecall; + end; + +implementation + +end. diff --git a/Source/Windows7/dwJumpLists.pas b/Source/Windows7/dwJumpLists.pas new file mode 100644 index 0000000..22bde3a --- /dev/null +++ b/Source/Windows7/dwJumpLists.pas @@ -0,0 +1,725 @@ +unit dwJumpLists; + +interface + +{$INCLUDE '..\Packages\DelphiVersions.inc'} + +uses + Classes, Contnrs, ShlObj, + {$IFNDEF Delphi2007_Up} + dwShellItem, + {$ENDIF} + dwCustomDestinationList, dwObjectArray; + +type + TJumpListKnowCategory = (jlkcFrequent, jlkcRecent); + TJumpListKnowCategories = set of TJumpListKnowCategory; + +const + KNOWN_CATEGORIES_DEFAULT: TJumpListKnowCategories = [jlkcFrequent, jlkcRecent]; + +type + TdwLinkObjectType = (lotShellLink, lotShellItem); + +type + TdwLinkObjectItem = class; + TdwLinkObjectList = class; + TdwLinkCategoryItem = class; + TdwLinkCategoryList = class; + TdwJumpLists = class; + + TObjectArray = class(TInterfacedObject, IObjectArray) + private + FObjectList: TInterfaceList; + + function CreateShellLink(ObjectItem: TdwLinkObjectItem): IShellLinkW; + function CreateShellItem(ObjectItem: TdwLinkObjectItem): IShellItem; + procedure LoadObjectList(ObjectList: TdwLinkObjectList; DeletedObjects: IObjectArray); + protected + public + constructor Create(ObjectList: TdwLinkObjectList; DeletedObjects: IObjectArray); + destructor Destroy; override; + + function GetAt(uiIndex: Cardinal; riid: PGUID): IUnknown; safecall; + function GetCount: Cardinal; safecall; + end; + + TdwShellItem = class(TPersistent) + private + FFilename: WideString; + procedure SetFilename(const Value: WideString); + protected + public + constructor Create; + procedure Assign(Source: TPersistent); override; + published + property Filename: WideString read FFilename write SetFilename; + end; + + TdwShellLink = class(TPersistent) + private + FDisplayName: WideString; + FArguments: WideString; + FIconFilename: WideString; + FIconIndex: Integer; + procedure SetArguments(const Value: WideString); + procedure SetDisplayName(const Value: WideString); + procedure SetIconFilename(const Value: WideString); + procedure SetIconIndex(const Value: Integer); + protected + public + constructor Create; + procedure Assign(Source: TPersistent); override; + published + property Arguments: WideString read FArguments write SetArguments; + property DisplayName: WideString read FDisplayName write SetDisplayName; + property IconFilename: WideString read FIconFilename write SetIconFilename; + property IconIndex: Integer read FIconIndex write SetIconIndex; + end; + + TdwLinkObjectItem = class(TCollectionItem) + private + FTag: Integer; + FObjectType: TdwLinkObjectType; + FShellItem: TdwShellItem; + FShellLink: TdwShellLink; + procedure SetTag(const Value: Integer); + procedure SetObjectType(const Value: TdwLinkObjectType); + procedure SetShellItem(const Value: TdwShellItem); + procedure SetShellLink(const Value: TdwShellLink); + protected + public + constructor Create(Collection: TCollection); override; + destructor Destroy; override; + + procedure Assign(Source: TPersistent); override; + published + property Tag: Integer read FTag write SetTag default 0; + property ObjectType: TdwLinkObjectType read FObjectType write SetObjectType default lotShellItem; + property ShellItem: TdwShellItem read FShellItem write SetShellItem; + property ShellLink: TdwShellLink read FShellLink write SetShellLink; + end; + + TdwLinkObjectList = class(TCollection) + private + FOwner: TPersistent; + function GetItem(Index: Integer): TdwLinkObjectItem; + procedure SetItem(Index: Integer; Value: TdwLinkObjectItem); + function GetObjectArray(DeletedObjects: IObjectArray): IObjectArray; + protected + function GetOwner: TPersistent; override; + procedure Update(Item: TCollectionItem); override; + public + constructor Create(Owner: TPersistent); + destructor Destroy; override; + + function Add: TdwLinkObjectItem; + function AddShellItem(const Filename: WideString): TdwLinkObjectItem; + function AddShellLink(const DisplayName, Arguments: WideString; const IconFilename: WideString = ''; IconIndex: Integer = 0): TdwLinkObjectItem; + function AddItem(Item: TdwLinkObjectItem; Index: Integer): TdwLinkObjectItem; + function Insert(Index: Integer): TdwLinkObjectItem; + + property Items[Index: Integer]: TdwLinkObjectItem read GetItem write SetItem; default; + end; + + TdwLinkCategoryItem = class(TCollectionItem) + private + FTitle: WideString; + FTag: Integer; + FItems: TdwLinkObjectList; + procedure SetTitle(const Value: WideString); + procedure SetTag(const Value: Integer); + procedure SetItems(const Value: TdwLinkObjectList); + protected + public + constructor Create(Collection: TCollection); override; + destructor Destroy; override; + + procedure Assign(Source: TPersistent); override; + published + property Title: WideString read FTitle write SetTitle; + property Tag: Integer read FTag write SetTag default 0; + property Items: TdwLinkObjectList read FItems write SetItems; + end; + + TdwLinkCategoryList = class(TCollection) + private + FOwner: TPersistent; + function GetItem(Index: Integer): TdwLinkCategoryItem; + procedure SetItem(Index: Integer; Value: TdwLinkCategoryItem); + protected + function GetOwner: TPersistent; override; + procedure Update(Item: TCollectionItem); override; + public + constructor Create(Owner: TPersistent); + destructor Destroy; override; + + function Add: TdwLinkCategoryItem; + function AddItem(Item: TdwLinkCategoryItem; Index: Integer): TdwLinkCategoryItem; + function Insert(Index: Integer): TdwLinkCategoryItem; + + property Items[Index: Integer]: TdwLinkCategoryItem read GetItem write SetItem; default; + end; + + TdwJumpLists = class(TComponent) + private + FDisplayKnowCategories: TJumpListKnowCategories; + FDestinationList: ICustomDestinationList; + FIsSupported: Boolean; + FCategories: TdwLinkCategoryList; + FTasks: TdwLinkObjectList; + FAppID: WideString; + + procedure SetDisplayKnowCategories(const Value: TJumpListKnowCategories); + function DoStoreDisplayKnowCategories: Boolean; + procedure SetCategories(const Value: TdwLinkCategoryList); + procedure SetTasks(const Value: TdwLinkObjectList); + procedure SetAppID(const Value: WideString); + protected + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + function GetMaxJumpListEntryCount: Integer; + function Commit: Boolean; + + property IsSupported: Boolean read FIsSupported; + published + property DisplayKnowCategories: TJumpListKnowCategories read FDisplayKnowCategories write SetDisplayKnowCategories stored DoStoreDisplayKnowCategories; + property Categories: TdwLinkCategoryList read FCategories write SetCategories; + property Tasks: TdwLinkObjectList read FTasks write SetTasks; + property AppID: WideString read FAppID write SetAppID; + end; + +implementation + +uses + ComObj, ActiveX, SysUtils; + +{ TObjectArray } + +constructor TObjectArray.Create(ObjectList: TdwLinkObjectList; DeletedObjects: IObjectArray); +begin + inherited Create; + + FObjectList := TInterfaceList.Create; + LoadObjectList(ObjectList, DeletedObjects); +end; + +function TObjectArray.CreateShellItem(ObjectItem: TdwLinkObjectItem): IShellItem; +begin + if ObjectItem.FObjectType = lotShellItem then + begin + SHCreateItemFromParsingName(PWideChar(ObjectItem.ShellItem.Filename), nil, StringToGUID(SID_IShellItem), Result); + end + else + begin + Result := nil; + end; +end; + +function TObjectArray.CreateShellLink(ObjectItem: TdwLinkObjectItem): IShellLinkW; +var + ShellLink: IShellLinkW; + PPS: IPropertyStore; + K: TPropertyKey; + P: tagPROPVARIANT; +begin + if ObjectItem.FObjectType = lotShellLink then + begin + CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IID_IShellLinkW, ShellLink); + ShellLink.SetPath(PWideChar(WideString(GetModuleName(HInstance)))); + ShellLink.SetArguments(PWideChar(ObjectItem.ShellLink.FArguments)); + if ObjectItem.ShellLink.FIconFilename <> '' then + ShellLink.SetIconLocation(PWideChar(ObjectItem.ShellLink.FIconFilename), ObjectItem.ShellLink.FIconIndex) + else + ShellLink.SetIconLocation(PWideChar(WideString(GetModuleName(HInstance))), 0); + PPS := ShellLink as IPropertyStore; + K.fmtid := StringToGUID('{F29F85E0-4FF9-1068-AB91-08002B27B3D9}'); + K.pid := 2; + P.vt := VT_LPWSTR; + P.pwszVal := PWideChar(ObjectItem.ShellLink.FDisplayName); + PPS.SetValue(K, P); + PPS.Commit; + Result := ShellLink; + end + else + begin + Result := nil; + end; +end; + +destructor TObjectArray.Destroy; +begin + FObjectList.Free; + + inherited; +end; + +function TObjectArray.GetAt(uiIndex: Cardinal; riid: PGUID): IUnknown; +begin + Result := FObjectList[uiIndex]; +end; + +function TObjectArray.GetCount: Cardinal; +begin + Result := FObjectList.Count; +end; + +procedure TObjectArray.LoadObjectList(ObjectList: TdwLinkObjectList; DeletedObjects: IObjectArray); +var + I: Integer; + ObjectItem: TdwLinkObjectItem; +begin + for I := 0 to ObjectList.Count - 1 do + begin + ObjectItem := ObjectList.Items[I]; + case ObjectItem.FObjectType of + lotShellLink: + begin + FObjectList.Add(CreateShellLink(ObjectItem)); + end; + lotShellItem: + begin + FObjectList.Add(CreateShellItem(ObjectItem)); + end; + end; + end; +end; + +{ TdwShellLink } + +procedure TdwShellItem.Assign(Source: TPersistent); +begin + if Source is TdwShellItem then + begin + Self.FFilename := (Source as TdwShellItem).FFilename; + end + else + begin + inherited Assign(Source); + end; +end; + +constructor TdwShellItem.Create; +begin + inherited Create; + + FFilename := ''; +end; + +procedure TdwShellItem.SetFilename(const Value: WideString); +begin + FFilename := Value; +end; + +{ TdwShellLink } + +procedure TdwShellLink.Assign(Source: TPersistent); +begin + if Source is TdwShellLink then + begin + Self.FArguments := (Source as TdwShellLink).FArguments; + Self.FDisplayName := (Source as TdwShellLink).FDisplayName; + Self.FIconFilename := (Source as TdwShellLink).FIconFilename; + Self.FIconIndex := (Source as TdwShellLink).FIconIndex; + end + else + begin + inherited Assign(Source); + end; +end; + +constructor TdwShellLink.Create; +begin + inherited Create; + + FDisplayName := ''; + FArguments := ''; + FIconFilename := ''; + FIconIndex := 0; +end; + +procedure TdwShellLink.SetArguments(const Value: WideString); +begin + FArguments := Value; +end; + +procedure TdwShellLink.SetDisplayName(const Value: WideString); +begin + FDisplayName := Value; +end; + +procedure TdwShellLink.SetIconFilename(const Value: WideString); +begin + FIconFilename := Value; +end; + +procedure TdwShellLink.SetIconIndex(const Value: Integer); +begin + FIconIndex := Value; +end; + +{ TdwLinkObjectItem } + +procedure TdwLinkObjectItem.Assign(Source: TPersistent); +begin + if Source is TdwLinkObjectItem then + begin + Self.FTag := (Source as TdwLinkObjectItem).FTag; + Self.FObjectType := (Source as TdwLinkObjectItem).FObjectType; + end + else + begin + inherited Assign(Source); + end; +end; + +constructor TdwLinkObjectItem.Create(Collection: TCollection); +begin + inherited Create(Collection); + FTag := 0; + FObjectType := lotShellItem; + FShellItem := TdwShellItem.Create(); + FShellLink := TdwShellLink.Create(); +end; + +destructor TdwLinkObjectItem.Destroy; +begin + FShellItem.Free; + FShellLink.Free; + + inherited; +end; + +procedure TdwLinkObjectItem.SetObjectType(const Value: TdwLinkObjectType); +begin + FObjectType := Value; +end; + +procedure TdwLinkObjectItem.SetShellItem(const Value: TdwShellItem); +begin + FShellItem.Assign(Value); +end; + +procedure TdwLinkObjectItem.SetShellLink(const Value: TdwShellLink); +begin + FShellLink := Value; +end; + +procedure TdwLinkObjectItem.SetTag(const Value: Integer); +begin + FTag := Value; +end; + +{ TdwLinkObjectList } + +function TdwLinkObjectList.Add: TdwLinkObjectItem; +begin + Result := AddItem(nil, -1); +end; + +function TdwLinkObjectList.AddItem(Item: TdwLinkObjectItem; Index: Integer): TdwLinkObjectItem; +begin + if Item = nil then + begin + Result := TdwLinkObjectItem.Create(Self); + end + else + begin + Result := Item; + if Assigned(Item) then + begin + Result.Collection := Self; + if Index < Count then + Index := Count - 1; + Result.Index := Index; + end; + end; +end; + +function TdwLinkObjectList.AddShellItem(const Filename: WideString): TdwLinkObjectItem; +begin + Result := Add; + + Result.FObjectType := lotShellItem; + Result.ShellItem.FFilename := Filename; +end; + +function TdwLinkObjectList.AddShellLink(const DisplayName, Arguments, IconFilename: WideString; IconIndex: Integer): TdwLinkObjectItem; +begin + Result := Add; + Result.FObjectType := lotShellLink; + Result.ShellLink.FDisplayName := DisplayName; + Result.ShellLink.FArguments := Arguments; + Result.ShellLink.FIconFilename := IconFilename; + Result.ShellLink.FIconIndex := IconIndex; +end; + +constructor TdwLinkObjectList.Create(Owner: TPersistent); +begin + inherited Create(TdwLinkObjectItem); + FOwner := Owner; +end; + +destructor TdwLinkObjectList.Destroy; +begin + + inherited; +end; + +function TdwLinkObjectList.GetItem(Index: Integer): TdwLinkObjectItem; +begin + Result := TdwLinkObjectItem(inherited GetItem(Index)); +end; + +function TdwLinkObjectList.GetObjectArray(DeletedObjects: IObjectArray): IObjectArray; +begin + Result := TObjectArray.Create(Self, DeletedObjects) as IObjectArray; +end; + +function TdwLinkObjectList.GetOwner: TPersistent; +begin + Result := FOwner; +end; + +function TdwLinkObjectList.Insert(Index: Integer): TdwLinkObjectItem; +begin + Result := AddItem(nil, Index); +end; + +procedure TdwLinkObjectList.SetItem(Index: Integer; Value: TdwLinkObjectItem); +begin + inherited SetItem(Index, Value); +end; + +procedure TdwLinkObjectList.Update(Item: TCollectionItem); +begin + // nothing to do +end; + +{ TdwLinkCategoryItem } + +procedure TdwLinkCategoryItem.Assign(Source: TPersistent); +begin + if Source is TdwLinkCategoryItem then + begin + Self.FTitle := (Source as TdwLinkCategoryItem).FTitle; + Self.FTag := (Source as TdwLinkCategoryItem).FTag; + end + else + begin + inherited Assign(Source); + end; +end; + +constructor TdwLinkCategoryItem.Create(Collection: TCollection); +begin + inherited Create(Collection); + + FTitle := ''; + FTag := 0; + FItems := TdwLinkObjectList.Create(Self); +end; + +destructor TdwLinkCategoryItem.Destroy; +begin + FItems.Free; + + inherited Destroy; +end; + +procedure TdwLinkCategoryItem.SetItems(const Value: TdwLinkObjectList); +begin + FItems.Assign(Value); +end; + +procedure TdwLinkCategoryItem.SetTag(const Value: Integer); +begin + FTag := Value; +end; + +procedure TdwLinkCategoryItem.SetTitle(const Value: WideString); +begin + FTitle := Value; +end; + +{ TdwLinkCategoryList } + +function TdwLinkCategoryList.Add: TdwLinkCategoryItem; +begin + Result := AddItem(nil, -1); +end; + +function TdwLinkCategoryList.AddItem(Item: TdwLinkCategoryItem; Index: Integer): TdwLinkCategoryItem; +begin + if Item = nil then + begin + Result := TdwLinkCategoryItem.Create(Self); + end + else + begin + Result := Item; + if Assigned(Item) then + begin + Result.Collection := Self; + if Index < Count then + Index := Count - 1; + Result.Index := Index; + end; + end; +end; + +constructor TdwLinkCategoryList.Create(Owner: TPersistent); +begin + inherited Create(TdwLinkCategoryItem); + FOwner := Owner; +end; + +destructor TdwLinkCategoryList.Destroy; +begin + + inherited Destroy; +end; + +function TdwLinkCategoryList.GetItem(Index: Integer): TdwLinkCategoryItem; +begin + Result := TdwLinkCategoryItem(inherited GetItem(Index)); +end; + +function TdwLinkCategoryList.GetOwner: TPersistent; +begin + Result := FOwner; +end; + +function TdwLinkCategoryList.Insert(Index: Integer): TdwLinkCategoryItem; +begin + Result := AddItem(nil, Index); +end; + +procedure TdwLinkCategoryList.SetItem(Index: Integer; Value: TdwLinkCategoryItem); +begin + inherited SetItem(Index, Value); +end; + +procedure TdwLinkCategoryList.Update(Item: TCollectionItem); +begin + // nothing to do +end; + +{ TdwJumpLists } + +function TdwJumpLists.Commit: Boolean; +var + MaxSlots: Cardinal; + IdxCat: Integer; + DeletedObjects: IObjectArray; + Category: TdwLinkCategoryItem; +begin + if IsSupported then + try + DeletedObjects := FDestinationList.BeginList(MaxSlots, @IID_IObjectArray); + + for IdxCat := 0 to FCategories.Count - 1 do + begin + Category := FCategories.Items[IdxCat]; + if Category.Items.Count > 0 then + begin + FDestinationList.AppendCategory(PWideChar(Category.FTitle), Category.Items.GetObjectArray(DeletedObjects)); + end; + end; + + if FTasks.Count > 0 then + FDestinationList.AddUserTasks(FTasks.GetObjectArray(DeletedObjects)); + + if jlkcFrequent in FDisplayKnowCategories then + FDestinationList.AppendKnownCategory(KDC_FREQUENT); + if jlkcRecent in FDisplayKnowCategories then + FDestinationList.AppendKnownCategory(KDC_RECENT); + + FDestinationList.CommitList; + Result := True; + except + Result := False; + end + else + begin + Result := False; + end; +end; + +constructor TdwJumpLists.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + + if CheckWin32Version(6, 1) then + begin + FDisplayKnowCategories := KNOWN_CATEGORIES_DEFAULT; + FDestinationList := CreateComObject(CLSID_CustomDestinationList) as ICustomDestinationList; + end + else + begin + FDestinationList := nil; + end; + FIsSupported := FDestinationList <> nil; + + FCategories := TdwLinkCategoryList.Create(Self); + FTasks := TdwLinkObjectList.Create(Self); +end; + +destructor TdwJumpLists.Destroy; +begin + FDestinationList := nil; + FCategories.Free; + FTasks.Free; + + inherited Destroy; +end; + +function TdwJumpLists.DoStoreDisplayKnowCategories: Boolean; +begin + Result := FDisplayKnowCategories <> KNOWN_CATEGORIES_DEFAULT; +end; + +function TdwJumpLists.GetMaxJumpListEntryCount: Integer; +var + Objects: IObjectArray; + MaxSlots: Cardinal; +begin + if not IsSupported then + begin + Result := -1; + end + else + begin + Objects := FDestinationList.BeginList(MaxSlots, @IID_IObjectArray); + FDestinationList.AbortList; + Result := MaxSlots; + end; +end; + +procedure TdwJumpLists.SetAppID(const Value: WideString); +begin + FAppID := Value; + FDestinationList.SetAppID(PWideChar(Value)); +end; + +procedure TdwJumpLists.SetCategories(const Value: TdwLinkCategoryList); +begin + FCategories.Assign(Value); +end; + +procedure TdwJumpLists.SetDisplayKnowCategories(const Value: TJumpListKnowCategories); +begin + if FDisplayKnowCategories <> Value then + begin + FDisplayKnowCategories := Value; + end; +end; + +procedure TdwJumpLists.SetTasks(const Value: TdwLinkObjectList); +begin + FTasks.Assign(Value); +end; + +end. diff --git a/Source/Windows7/dwObjectArray.pas b/Source/Windows7/dwObjectArray.pas new file mode 100644 index 0000000..c7eb140 --- /dev/null +++ b/Source/Windows7/dwObjectArray.pas @@ -0,0 +1,20 @@ +unit dwObjectArray; + +interface + +uses + Windows; + +const + IID_IObjectArray: TGUID = '{92CA9DCD-5622-4BBA-A805-5E9F541BD8C9}'; + +type + IObjectArray = interface + ['{92CA9DCD-5622-4BBA-A805-5E9F541BD8C9}'] + function GetCount(): UInt; safecall; + function GetAt(uiIndex: UInt; riid: PGUID): IUnknown; safecall; + end; + +implementation + +end. diff --git a/Source/Windows7/dwOverlayIcon.pas b/Source/Windows7/dwOverlayIcon.pas new file mode 100644 index 0000000..054b3f0 --- /dev/null +++ b/Source/Windows7/dwOverlayIcon.pas @@ -0,0 +1,116 @@ +unit dwOverlayIcon; + +interface + +uses + Classes, ImgList, + dwTaskbarComponents; + +type + TdwOverlayIcon = class(TdwTaskbarComponent) + private + FImages: TCustomImageList; + FImageIndex: Integer; + FHint: WideString; + procedure SetImages(const Value: TCustomImageList); + procedure SetImageIndex(const Value: Integer); + function DoShowOverlay: Boolean; + procedure SetHint(const Value: WideString); + protected + function DoInitialize: Boolean; override; + procedure DoUpdate; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + published + property Images: TCustomImageList read FImages write SetImages; + property ImageIndex: Integer read FImageIndex write SetImageIndex; + property Hint: WideString read FHint write SetHint; + end; + +implementation + +uses + SysUtils, Graphics; + +{ TdwOverlayIcon } + +constructor TdwOverlayIcon.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + + FImages := nil; + FImageIndex := -1; + FHint := ''; +end; + +destructor TdwOverlayIcon.Destroy; +begin + inherited Destroy; +end; + +function TdwOverlayIcon.DoInitialize: Boolean; +begin + Result := DoShowOverlay; +end; + +function TdwOverlayIcon.DoShowOverlay: Boolean; +var + Icon: TIcon; +begin + if CheckWin32Version(6, 1) and (TaskbarList3 <> nil) then + begin + if (FImages = nil) or (FImageIndex < 0) or (FImageIndex >= FImages.Count) then + begin + TaskbarList3.SetOverlayIcon(TaskBarEntryHandle, 0, nil); + Result := True; + end + else + begin + Icon := TIcon.Create; + try + FImages.GetIcon(FImageIndex, Icon); + TaskbarList3.SetOverlayIcon(TaskBarEntryHandle, Icon.ReleaseHandle, PWideChar(FHint)); + Result := True; + finally + Icon.Free; + end; + end; + end + else + begin + Result := False; + end; +end; + +procedure TdwOverlayIcon.DoUpdate; +begin + DoShowOverlay; +end; + +procedure TdwOverlayIcon.SetHint(const Value: WideString); +begin + if FHint <> Value then + begin + FHint := Value; + SendUpdateMessage; + end; +end; + +procedure TdwOverlayIcon.SetImageIndex(const Value: Integer); +begin + if FImageIndex <> Value then + begin + FImageIndex := Value; + SendUpdateMessage; + end; +end; + +procedure TdwOverlayIcon.SetImages(const Value: TCustomImageList); +begin + FImages := Value; + SendUpdateMessage; +end; + +end. diff --git a/Source/Windows7/dwProgressBar.pas b/Source/Windows7/dwProgressBar.pas new file mode 100644 index 0000000..2744f31 --- /dev/null +++ b/Source/Windows7/dwProgressBar.pas @@ -0,0 +1,534 @@ +unit dwProgressBar; + +interface + +{$INCLUDE 'DelphiVersions.inc'} + +uses + SysUtils, Classes, Controls, ComCtrls, Messages, Graphics, + dwTaskbarComponents; + +const + ICC_PROGRESS_CLASS = $00000020; + +const + PBS_SMOOTH = $01; + PBS_VERTICAL = $04; + PBS_MARQUEE = $08; + PBS_SMOOTHREVERSE = $10; + +const + PBM_SETMARQUEE = WM_USER + 10; + PBM_SETSTATE = WM_USER + 16; + PBM_GETSTATE = WM_USER + 17; + +const + PBST_NORMAL = $0001; + PBST_ERROR = $0002; + PBST_PAUSED = $0003; + +type + TdwProgressBarState = (pbstMarquee = 0, pbstNormal = 1, pbstError = 2, pbstPaused = 3); + + TdwProgressBar = class(TdwTaskbarWinControl) + private // CodeGear :: ProgressBar + FMin: Integer; + FMax: Integer; + FPosition: Integer; + FStep: Integer; + FOrientation: TProgressBarOrientation; + FSmooth: Boolean; + FSmoothReverse: Boolean; + FBarColor: TColor; + FBackgroundColor: TColor; + + function GetMin: Integer; + function GetMax: Integer; + function GetPosition: Integer; + procedure SetParams(AMin, AMax: Integer); + procedure SetMin(Value: Integer); + procedure SetMax(Value: Integer); + procedure SetPosition(Value: Integer); + procedure SetStep(Value: Integer); + procedure SetOrientation(Value: TProgressBarOrientation); + procedure SetSmooth(Value: Boolean); + procedure SetSmoothReverse(Value: Boolean); + procedure SetBarColor(Value: TColor); + procedure SetBackgroundColor(Value: TColor); + procedure WMEraseBkGnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND; + + private + {$IFDEF Delphi2006_UP} + const LIMIT_16 = 65535; + {$ENDIF} + class procedure ProgressLimitError; + + private + FMsgUpdateTaskbar: Cardinal; + FProgressBarState: TdwProgressBarState; + FMarqueeEnabled: Boolean; + FMarqueeInterval: Integer; + FShowInTaskbar: Boolean; + + procedure SetProgressBarState(const Value: TdwProgressBarState); + procedure SetMarqueeInterval(const Value: Integer); + procedure SetShowInTaskbar(const Value: Boolean); + procedure SetMarqueeEnabled(const Value: Boolean); + + protected // CodeGear :: ProgressBar + procedure CreateParams(var Params: TCreateParams); override; + procedure CreateWnd; override; + procedure DestroyWnd; override; + + protected + class function GetComCtrlClass: Integer; override; + class function GetComCtrlClassName: PChar; override; + + procedure WndProc(var Msg: TMessage); override; + + public // CodeGear ProgressBar + constructor Create(AOwner: TComponent); override; + procedure StepIt; + procedure StepBy(Delta: Integer); + + published // CodeGear ProgressBar + property Align; + property Anchors; + property BorderWidth; + property DragCursor; + property DragKind; + property DragMode; + property Enabled; + property Hint; + property Constraints; + property Min: Integer read GetMin write SetMin default 0; + property Max: Integer read GetMax write SetMax default 100; + property Orientation: TProgressBarOrientation read FOrientation write SetOrientation default pbHorizontal; + property ParentShowHint; + property PopupMenu; + property Position: Integer read GetPosition write SetPosition default 0; + property Smooth: Boolean read FSmooth write SetSmooth default False; + property SmoothReverse: Boolean read FSmoothReverse write SetSmoothReverse default False; + property Step: Integer read FStep write SetStep default 10; + property BarColor: TColor read FBarColor write SetBarColor default clDefault; + property BackgroundColor: TColor read FBackgroundColor write SetBackgroundColor default clDefault; + property ShowHint; + property TabOrder; + property TabStop; + property Visible; + property OnContextPopup; + property OnDragDrop; + property OnDragOver; + property OnEndDock; + property OnEndDrag; + property OnEnter; + property OnExit; + {$IFDEF Delphi2006_UP} + property OnMouseActivate; + property OnMouseEnter; + property OnMouseLeave; + {$ENDIF} + property OnMouseDown; + property OnMouseMove; + property OnMouseUp; + property OnStartDock; + property OnStartDrag; + property DoubleBuffered; + {$IFDEF Delphi2009_Up} + property ParentDoubleBuffered; + {$ENDIF} + + published + property ProgressBarState: TdwProgressBarState read FProgressBarState write SetProgressBarState default pbstNormal; + property MarqueeEnabled: Boolean read FMarqueeEnabled write SetMarqueeEnabled default False; + property MarqueeInterval: Integer read FMarqueeInterval write SetMarqueeInterval default 75; + property ShowInTaskbar: Boolean read FShowInTaskbar write SetShowInTaskbar default False; + end; + +procedure Register; + +implementation + +uses + Consts, + Themes, CommCtrl, Windows, + dwTaskbarList; + +{$IFNDEF Delphi2006_UP} + const LIMIT_16 = 65535; +{$ENDIF} + +procedure Register; +begin + RegisterComponents('Windows 6+', [TdwProgressBar]); +end; + +{ TdwProgressBar } + +constructor TdwProgressBar.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + + Width := 150; + Height := GetSystemMetrics(SM_CYVSCROLL); + FMin := 0; + FMax := 100; + FStep := 10; + FOrientation := pbHorizontal; + FBarColor := clDefault; + FBackgroundColor := clDefault; + FMarqueeInterval := 10; + FSmooth := False; + FSmoothReverse := False; + FMarqueeInterval := 50; + FProgressBarState := pbstNormal; + FShowInTaskbar := False; + + FMsgUpdateTaskbar := RegisterWindowMessage('dw.Control.Update.Taskbar'); +end; + +procedure TdwProgressBar.CreateParams(var Params: TCreateParams); +begin + inherited CreateParams(Params); + + with Params do + begin + if FOrientation = pbVertical then + Style := Style or PBS_VERTICAL; + if FSmooth then + Style := Style or PBS_SMOOTH; + if (FProgressBarState = pbstMarquee) and ThemeServices.ThemesEnabled and CheckWin32Version(5, 1) then + Style := Style or PBS_MARQUEE; + if FSmoothReverse and ThemeServices.ThemesEnabled and CheckWin32Version(6, 0) then + Style := Style or PBS_SMOOTHREVERSE; + end; +end; + +procedure TdwProgressBar.CreateWnd; +begin + inherited CreateWnd; + + if In32BitMode then + begin + SendMessage(Handle, PBM_SETRANGE32, FMin, FMax); + end + else + begin + SendMessage(Handle, PBM_SETRANGE, 0, MakeLong(FMin, FMax)); + end; + + SendMessage(Handle, PBM_SETSTEP, FStep, 0); + Position := FPosition; + BarColor := FBarColor; + BackgroundColor := FBackgroundColor; + ProgressBarState := FProgressBarState; + + if ThemeServices.ThemesEnabled and CheckWin32Version(5, 1) then + begin + if FProgressBarState = pbstMarquee then + SendMessage(Handle, PBM_SETMARQUEE, Integer(BOOL(FMarqueeEnabled)), FMarqueeInterval); + end; +end; + +procedure TdwProgressBar.DestroyWnd; +begin + FPosition := Position; + inherited; +end; + +class function TdwProgressBar.GetComCtrlClass: Integer; +begin + Result := ICC_PROGRESS_CLASS; +end; + +class function TdwProgressBar.GetComCtrlClassName: PChar; +begin + Result := PROGRESS_CLASS; +end; + +function TdwProgressBar.GetMax: Integer; +begin + if HandleAllocated and In32BitMode then + Result := SendMessage(Handle, PBM_GETRANGE, 0, 0) + else + Result := FMax; +end; + +function TdwProgressBar.GetMin: Integer; +begin + if HandleAllocated and In32BitMode then + Result := SendMessage(Handle, PBM_GETRANGE, 1, 0) + else + Result := FMin; +end; + +function TdwProgressBar.GetPosition: Integer; +begin + if HandleAllocated then + begin + if In32BitMode then + Result := SendMessage(Handle, PBM_GETPOS, 0, 0) + else + Result := SendMessage(Handle, PBM_DELTAPOS, 0, 0); + end + else + begin + Result := FPosition; + end; +end; + +class procedure TdwProgressBar.ProgressLimitError; +begin + raise Exception.CreateFmt(SOutOfRange, [0, LIMIT_16]); +end; + +procedure TdwProgressBar.SetBackgroundColor(Value: TColor); +var + ColorRef: TColorRef; +begin + if FBackgroundColor <> Value then + begin + FBackgroundColor := Value; + if Value = clDefault then + ColorRef := TColorRef($FF000000) + else + ColorRef := TColorRef(ColorToRGB(Color)); + + if HandleAllocated then + SendMessage(Handle, PBM_SETBKCOLOR, 0, ColorRef); + end; +end; + +procedure TdwProgressBar.SetBarColor(Value: TColor); +var + ColorRef: TColorRef; +begin + if FBarColor <> Value then + begin + FBarColor := Value; + if Value = clDefault then + ColorRef := TColorRef($FF000000) + else + ColorRef := TColorRef(ColorToRGB(Color)); + + if HandleAllocated then + SendMessage(Handle, PBM_SETBARCOLOR, 0, ColorRef); + end; +end; + +procedure TdwProgressBar.SetMarqueeEnabled(const Value: Boolean); +begin + if FMarqueeEnabled <> Value then + begin + FMarqueeEnabled := Value; + if (FProgressBarState = pbstMarquee) and ThemeServices.ThemesEnabled and CheckWin32Version(5, 1) and HandleAllocated then + begin + SendMessage(Handle, PBM_SETMARQUEE, Integer(BOOL(FMarqueeEnabled)), FMarqueeInterval); + PostMessage(Handle, FMsgUpdateTaskbar, 0, 0); + end; + end; +end; + +procedure TdwProgressBar.SetMarqueeInterval(const Value: Integer); +begin + if FMarqueeInterval <> Value then + begin + FMarqueeInterval := Value; + if (FProgressBarState = pbstMarquee) and ThemeServices.ThemesEnabled and CheckWin32Version(5, 1) and HandleAllocated then + begin + SendMessage(Handle, PBM_SETMARQUEE, Integer(BOOL(FMarqueeEnabled)), FMarqueeInterval); + end; + end; +end; + +procedure TdwProgressBar.SetMax(Value: Integer); +begin + if FMax <> Value then + begin + SetParams(FMin, Value); + end; +end; + +procedure TdwProgressBar.SetMin(Value: Integer); +begin + if FMin <> Value then + begin + SetParams(Value, FMax); + end; +end; + +procedure TdwProgressBar.SetOrientation(Value: TProgressBarOrientation); +begin + if FOrientation <> Value then + begin + FOrientation := Value; + RecreateWnd; + end; +end; + +procedure TdwProgressBar.SetParams(AMin, AMax: Integer); +begin + if AMax < AMin then + raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.ClassName]); + + if not In32BitMode and ((AMin < 0) or (AMax > LIMIT_16)) then + ProgressLimitError; + + if (FMin <> AMin) or (FMax <> AMax) then + begin + if HandleAllocated then + begin + if In32BitMode then + SendMessage(Handle, PBM_SETRANGE32, AMin, AMax) + else + SendMessage(Handle, PBM_SETRANGE, 0, MakeLong(AMin, AMax)); + + if FMin > FMax then + SendMessage(Handle, PBM_SETPOS, AMin, 0); + PostMessage(Handle, FMsgUpdateTaskbar, 0, 0); + end; + FMin := AMin; + FMax := AMax; + end; +end; + +procedure TdwProgressBar.SetPosition(Value: Integer); +begin + if not In32BitMode and ((Value < 0) or (Value > LIMIT_16)) then + ProgressLimitError; + + if HandleAllocated then + begin + SendMessage(Handle, PBM_SETPOS, Value, 0); + PostMessage(Handle, FMsgUpdateTaskbar, 0, 0); + end + else + begin + FPosition := Value; + end; +end; + +procedure TdwProgressBar.SetProgressBarState(const Value: TdwProgressBarState); +var + DoRecreate: Boolean; +begin + DoRecreate := (FProgressBarState <> Value); + FProgressBarState := Value; + if DoRecreate then + begin + RecreateWnd; + end + else + begin + if CheckWin32Version(6, 0) and HandleAllocated then + SendMessage(Handle, PBM_SETSTATE, Integer(Value), 0); + PostMessage(Handle, FMsgUpdateTaskbar, 0, 0); + end; +end; + +procedure TdwProgressBar.SetShowInTaskbar(const Value: Boolean); +begin + if FShowInTaskbar <> Value then + begin + FShowInTaskbar := Value; + PostMessage(Handle, FMsgUpdateTaskbar, 0, 0); + end; +end; + +procedure TdwProgressBar.SetSmooth(Value: Boolean); +begin + if FSmooth <> Value then + begin + FSmooth := Value; + RecreateWnd; + end; +end; + +procedure TdwProgressBar.SetSmoothReverse(Value: Boolean); +begin + if FSmoothReverse <> Value then + begin + FSmoothReverse := Value; + RecreateWnd; + end; +end; + +procedure TdwProgressBar.SetStep(Value: Integer); +begin + if FStep <> Value then + begin + FStep := Value; + if HandleAllocated then + begin + SendMessage(Handle, PBM_SETSTEP, FStep, 0); + PostMessage(Handle, FMsgUpdateTaskbar, 0, 0); + end; + end; +end; + +procedure TdwProgressBar.StepBy(Delta: Integer); +begin + if HandleAllocated then + begin + SendMessage(Handle, PBM_DELTAPOS, Delta, 0); + PostMessage(Handle, FMsgUpdateTaskbar, 0, 0); + end; +end; + +procedure TdwProgressBar.StepIt; +begin + if HandleAllocated then + begin + SendMessage(Handle, PBM_STEPIT, 0, 0); + PostMessage(Handle, FMsgUpdateTaskbar, 0, 0); + end; +end; + +procedure TdwProgressBar.WMEraseBkGnd(var Message: TWMEraseBkgnd); +begin + DefaultHandler(Message); +end; + +procedure TdwProgressBar.WndProc(var Msg: TMessage); +var + FormHandle: THandle; +begin + if Msg.Msg = FMsgUpdateTaskbar then + begin + if CheckWin32Version(6, 1) and (TaskbarList3 <> nil) then + begin + FormHandle := TaskBarEntryHandle; + if FormHandle <> INVALID_HANDLE_VALUE then + begin + if ShowInTaskbar then + begin + case FProgressBarState of + pbstMarquee: + begin + TaskbarList3.SetProgressState(FormHandle, TBPF_NORMAL); + if FMarqueeEnabled then + TaskbarList3.SetProgressState(FormHandle, TBPF_INDETERMINATE) + else + TaskbarList3.SetProgressState(FormHandle, TBPF_NOPROGRESS); + end; + pbstNormal: TaskbarList3.SetProgressState(FormHandle, TBPF_NORMAL); + pbstError: TaskbarList3.SetProgressState(FormHandle, TBPF_ERROR); + pbstPaused: TaskbarList3.SetProgressState(FormHandle, TBPF_PAUSED); + end; + if FProgressBarState in [pbstNormal, pbstError, pbstPaused] then + begin + TaskbarList3.SetProgressValue(FormHandle, Position - Min, Max - Min); + end; + end + else + begin + TaskbarList3.SetProgressState(FormHandle, TBPF_NOPROGRESS); + end; + end; + end; + end; + + inherited; +end; + +end. diff --git a/Source/Windows7/dwShellItem.pas b/Source/Windows7/dwShellItem.pas new file mode 100644 index 0000000..387cff1 --- /dev/null +++ b/Source/Windows7/dwShellItem.pas @@ -0,0 +1,111 @@ +unit dwShellItem; + +interface + +{$INCLUDE '.\..\Packages\DelphiVersions.inc'} + +uses + ActiveX, Windows; + +const + SID_IShellItem = '{43826d1e-e718-42ee-bc55-a1e261c37bfe}'; + SID_IPropertyStore = '{886d8eeb-8cf2-4446-8d02-cdba1dbdcf99}'; + +type + TIID = TGUID; + + IShellItem = interface(IUnknown) + [SID_IShellItem] + function BindToHandler(const pbc: IUnknown; const bhid: TGUID; const riid: TIID; out ppv): HResult; stdcall; + function GetParent(var ppsi: IShellItem): HResult; stdcall; + function GetDisplayName(sigdnName: DWORD; var ppszName: LPWSTR): HResult; stdcall; + function GetAttributes(sfgaoMask: DWORD; var psfgaoAttribs: DWORD): HResult; stdcall; + function Compare(const psi: IShellItem; hint: DWORD; var piOrder: Integer): HResult; stdcall; + end; + + _tagpropertykey = packed record + fmtid: TGUID; + pid: DWORD; + end; + PROPERTYKEY = _tagpropertykey; + PPropertyKey = ^TPropertyKey; + TPropertyKey = _tagpropertykey; + + IPropertyStore = interface(IUnknown) + [SID_IPropertyStore] + function GetCount(out cProps: DWORD): HResult; stdcall; + function GetAt(iProp: DWORD; out pkey: TPropertyKey): HResult; stdcall; + function GetValue(const key: TPropertyKey; out pv: TPropVariant): HResult; stdcall; + function SetValue(const key: TPropertyKey; const propvar: TPropVariant): HResult; stdcall; + function Commit: HResult; stdcall; + end; + +type + PSHItemID = ^TSHItemID; + _SHITEMID = record + cb: Word; + abID: array[0..0] of Byte; + end; + TSHItemID = _SHITEMID; + SHITEMID = _SHITEMID; + + PItemIDList = ^TItemIDList; + _ITEMIDLIST = record + mkid: TSHItemID; + end; + TItemIDList = _ITEMIDLIST; + ITEMIDLIST = _ITEMIDLIST; + +function SHCreateItemFromIDList(pidl: PItemIDList; const riid: TIID; out ppv): HResult; +function SHCreateItemFromParsingName(pszPath: LPCWSTR; const pbc: IUnknown; const riid: TIID; out ppv): HResult; + +implementation + +const + shell32 = 'shell32.dll'; + +var + Shell32Lib: HModule; + _SHCreateItemFromParsingName: function(pszPath: LPCWSTR; const pbc: IUnknown; const riid: TIID; out ppv): HResult; stdcall; + _SHCreateItemFromIDList: function(pidl: PItemIDList; const riid: TIID; out ppv): HResult; stdcall; + +procedure InitShlObj; {$IFDEF Delphi2006_Up} inline; {$ENDIF} +begin + Shell32Lib := GetModuleHandle(shell32); +end; + +function SHCreateItemFromParsingName(pszPath: LPCWSTR; const pbc: IUnknown; const riid: TIID; out ppv): HResult; +begin + if Assigned(_SHCreateItemFromParsingName) then + Result := _SHCreateItemFromParsingName(pszPath, pbc, riid, ppv) + else + begin + InitShlObj; + Result := E_NOTIMPL; + if Shell32Lib > 0 then + begin + _SHCreateItemFromParsingName := GetProcAddress(Shell32Lib, 'SHCreateItemFromParsingName'); // Do not localize + if Assigned(_SHCreateItemFromParsingName) then + Result := _SHCreateItemFromParsingName(pszPath, pbc, riid, ppv); + end; + end; +end; + +function SHCreateItemFromIDList(pidl: PItemIDList; const riid: TIID; out ppv): HResult; +begin + if Assigned(_SHCreateItemFromIDList) then + Result := _SHCreateItemFromIDList(pidl, riid, ppv) + else + begin + InitShlObj; + Result := E_NOTIMPL; + if Shell32Lib > 0 then + begin + _SHCreateItemFromIDList := GetProcAddress(Shell32Lib, 'SHCreateItemFromIDList'); // Do not localize + if Assigned(_SHCreateItemFromIDList) then + Result := _SHCreateItemFromIDList(pidl, riid, ppv); + end; + end; +end; + +end. diff --git a/Source/Windows7/dwTaskbarComponents.pas b/Source/Windows7/dwTaskbarComponents.pas new file mode 100644 index 0000000..ba7e712 --- /dev/null +++ b/Source/Windows7/dwTaskbarComponents.pas @@ -0,0 +1,259 @@ +unit dwTaskbarComponents; + +interface + +{$INCLUDE 'DelphiVersions.inc'} + +uses + Classes, Controls, Messages, dwTaskbarList; + +procedure InitCommonControls; stdcall; + +type + TdwTaskbarWinControl = class(TWinControl) + private + FIn32BitMode: Boolean; + FTaskbarList: ITaskbarList; + FTaskbarList2: ITaskbarList2; + FTaskbarList3: ITaskbarList3; + FTaskBarEntryHandle: THandle; + function GetTaskBarEntryHandle: THandle; + + protected + procedure CreateParams(var Params: TCreateParams); override; + property In32BitMode: Boolean read FIn32BitMode; + property TaskbarList: ITaskbarList read FTaskbarList; + property TaskbarList2: ITaskbarList2 read FTaskbarList2; + property TaskbarList3: ITaskbarList3 read FTaskbarList3; + + protected + class function GetComCtrlClass: Integer; virtual; abstract; + class function GetComCtrlClassName: PChar; virtual; abstract; + + public + constructor Create(AOwner: TComponent); override; + + property TaskBarEntryHandle: THandle read GetTaskBarEntryHandle write FTaskBarEntryHandle; + end; + + TdwTaskbarComponent = class(TComponent) + private + FHandle: Cardinal; + FMsgAutoInitialize: Cardinal; + FMsgUpdate: Cardinal; + FAutoInitialize: Boolean; + FIsInitialized: Boolean; + + FTaskbarList: ITaskbarList; + FTaskbarList2: ITaskbarList2; + FTaskbarList3: ITaskbarList3; + FTaskBarEntryHandle: THandle; + function GetTaskBarEntryHandle: THandle; + protected + procedure CheckInitalization; + procedure SendUpdateMessage; + function DoInitialize: Boolean; virtual; + procedure DoUpdate; virtual; + + property AutoInitialize: Boolean read FAutoInitialize write FAutoInitialize default True; + property TaskbarList: ITaskbarList read FTaskbarList; + property TaskbarList2: ITaskbarList2 read FTaskbarList2; + property TaskbarList3: ITaskbarList3 read FTaskbarList3; + + property Handle: Cardinal read FHandle; + function HandleAllocated: Boolean; + procedure WndProc(var Message: TMessage); virtual; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + property TaskBarEntryHandle: THandle read GetTaskBarEntryHandle write FTaskBarEntryHandle; + property IsInitialized: Boolean read FIsInitialized; + end; + +implementation + +uses + Forms, ComCtrls, Windows, ComObj, SysUtils; + +procedure InitCommonControls; stdcall; external comctl32; + +{ TdwCommon } + +constructor TdwTaskbarWinControl.Create(AOwner: TComponent); +var + Obj: IInterface; +begin + inherited; + + FIn32BitMode := InitCommonControl(GetComCtrlClass); + + Obj := CreateComObject(CLSID_TaskbarList); + if Obj = nil then + begin + FTaskbarList := nil; + end + else + begin + FTaskbarList := ITaskbarList(Obj); + FTaskbarList.HrInit; + + FTaskbarList.QueryInterface(CLSID_TaskbarList2, FTaskbarList2); + FTaskbarList.QueryInterface(CLSID_TaskbarList3, FTaskbarList3); + end; + +end; + +procedure TdwTaskbarWinControl.CreateParams(var Params: TCreateParams); +begin + if not In32BitMode then + InitCommonControls; + + inherited; + + CreateSubClass(Params, GetComCtrlClassName); +end; + +function TdwTaskbarWinControl.GetTaskBarEntryHandle: THandle; +begin + if FTaskBarEntryHandle <> 0 then + begin + Result := FTaskBarEntryHandle; + end + else + begin + {$IFNDEF Delphi2007_Up} + Result := Application.Handle; + {$ELSE} + if not Application.MainFormOnTaskBar then + begin + Result := Application.Handle; + end + else + begin + Result := Application.MainForm.Handle; + end; + {$ENDIF} + end; +end; + +{ TdwCommonComponent } + +procedure TdwTaskbarComponent.CheckInitalization; +begin + if FIsInitialized then + raise Exception.Create('Thumbnails are initialized already.'); +end; + +constructor TdwTaskbarComponent.Create(AOwner: TComponent); +var + Obj: IInterface; +begin + inherited; + + Obj := CreateComObject(CLSID_TaskbarList); + if Obj = nil then + begin + FTaskbarList := nil; + end + else + begin + FTaskbarList := ITaskbarList(Obj); + FTaskbarList.HrInit; + + FTaskbarList.QueryInterface(CLSID_TaskbarList2, FTaskbarList2); + FTaskbarList.QueryInterface(CLSID_TaskbarList3, FTaskbarList3); + end; + + if not (csDesigning in ComponentState) then + begin + FHandle := Classes.AllocateHWnd(WndProc); + end + else + begin + FHandle := 0; + end; + + FAutoInitialize := True; + FIsInitialized := False; + FMsgAutoInitialize := RegisterWindowMessage('dw.Component.Taskbar.Thumbnails.Auto.Initialize'); + FMsgUpdate := RegisterWindowMessage('dw.Component.Taskbar.Thumbnails.Update'); + + if HandleAllocated then + PostMessage(Handle, FMsgAutoInitialize, 0, 0); +end; + +destructor TdwTaskbarComponent.Destroy; +begin + if HandleAllocated then + begin + Classes.DeallocateHWnd(FHandle); + FHandle := 0; + end; + inherited; +end; + +function TdwTaskbarComponent.DoInitialize: Boolean; +begin + Result := True; +end; + +procedure TdwTaskbarComponent.DoUpdate; +begin + +end; + +function TdwTaskbarComponent.GetTaskBarEntryHandle: THandle; +begin + if FTaskBarEntryHandle <> 0 then + begin + Result := FTaskBarEntryHandle; + end + else + begin + {$IFNDEF Delphi2007_Up} + Result := Application.Handle; + {$ELSE} + if not Application.MainFormOnTaskBar then + begin + Result := Application.Handle; + end + else + begin + Result := Application.MainForm.Handle; + end; + {$ENDIF} + end; +end; + +function TdwTaskbarComponent.HandleAllocated: Boolean; +begin + Result := FHandle <> 0; +end; + +procedure TdwTaskbarComponent.SendUpdateMessage; +begin + if HandleAllocated then + if FIsInitialized then + PostMessage(Handle, FMsgUpdate, 0, 0); +end; + +procedure TdwTaskbarComponent.WndProc(var Message: TMessage); +begin + if Message.Msg = FMsgAutoInitialize then + begin + if FAutoInitialize then + begin + FIsInitialized := DoInitialize; + end; + end + else + if Message.Msg = FMsgUpdate then + begin + if FIsInitialized then + DoUpdate; + end; + +end; + +end. diff --git a/Source/Windows7/dwTaskbarList.pas b/Source/Windows7/dwTaskbarList.pas new file mode 100644 index 0000000..7e250f4 --- /dev/null +++ b/Source/Windows7/dwTaskbarList.pas @@ -0,0 +1,100 @@ +unit dwTaskbarList; + +interface + +{$INCLUDE 'DelphiVersions.inc'} + +uses + Windows; + +{$IFNDEF Delphi2007_Up} +type + ULONGLONG = UInt64; +{$ENDIF} + +const + CLSID_TaskbarList: TGUID = '{56FDF344-FD6D-11D0-958A-006097C9A090}'; + CLSID_TaskbarList2: TGUID = '{602D4995-B13A-429B-A66E-1935E44F4317}'; + CLSID_TaskbarList3: TGUID = '{EA1AFB91-9E28-4B86-90E9-9E9F8A5EEFAF}'; + +const + THBF_ENABLED = $0000; + THBF_DISABLED = $0001; + THBF_DISMISSONCLICK = $0002; + THBF_NOBACKGROUND = $0004; + THBF_HIDDEN = $0008; + +const + THB_BITMAP = $0001; + THB_ICON = $0002; + THB_TOOLTIP = $0004; + THB_FLAGS = $0008; + +const + THBN_CLICKED = $1800; + +const + TBPF_NOPROGRESS = $00; + TBPF_INDETERMINATE = $01; + TBPF_NORMAL = $02; + TBPF_ERROR= $04; + TBPF_PAUSED = $08; + +const + TBATF_USEMDITHUMBNAIL: DWORD = $00000001; + TBATF_USEMDILIVEPREVIEW: DWORD = $00000002; + +const + WM_DWMSENDICONICTHUMBNAIL = $0323; + WM_DWMSENDICONICLIVEPREVIEWBITMAP = $0326; + +type + TTipString = array[0..259] of WideChar; + PTipString = ^TTipString; + tagTHUMBBUTTON = packed record + dwMask: DWORD; + iId: UINT; + iBitmap: UINT; + hIcon: HICON; + szTip: TTipString; + dwFlags: DWORD; + end; + THUMBBUTTON = tagTHUMBBUTTON; + THUMBBUTTONLIST = ^THUMBBUTTON; + TThumbButton = THUMBBUTTON; + TThumbButtonList = array of TThumbButton; + +type + ITaskbarList = interface + ['{56FDF342-FD6D-11D0-958A-006097C9A090}'] + procedure HrInit; safecall; + procedure AddTab(hwnd: Cardinal); safecall; + procedure DeleteTab(hwnd: Cardinal); safecall; + procedure ActivateTab(hwnd: Cardinal); safecall; + procedure SetActiveAlt(hwnd: Cardinal); safecall; + end; + + ITaskbarList2 = interface(ITaskbarList) + ['{602D4995-B13A-429B-A66E-1935E44F4317}'] + procedure MarkFullscreenWindow(hwnd: Cardinal; fFullscreen: Bool); safecall; + end; + + ITaskbarList3 = interface(ITaskbarList2) + ['{EA1AFB91-9E28-4B86-90E9-9E9F8A5EEFAF}'] + procedure SetProgressValue(hwnd: Cardinal; ullCompleted, ullTotal: ULONGLONG); safecall; + procedure SetProgressState(hwnd: Cardinal; tbpFlags: DWORD); safecall; + procedure RegisterTab(hwndTab: Cardinal; hwndMDI: Cardinal); safecall; + procedure UnregisterTab(hwndTab: Cardinal); safecall; + procedure SetTabOrder(hwndTab: Cardinal; hwndInsertBefore: Cardinal); safecall; + procedure SetTabActive(hwndTab: Cardinal; hwndMDI: Cardinal; tbatFlags: DWORD); safecall; + procedure ThumbBarAddButtons(hwnd: Cardinal; cButtons: UINT; Button: THUMBBUTTONLIST); safecall; + procedure ThumbBarUpdateButtons(hwnd: Cardinal; cButtons: UINT; pButton: THUMBBUTTONLIST); safecall; + procedure ThumbBarSetImageList(hwnd: Cardinal; himl: Cardinal); safecall; + procedure SetOverlayIcon(hwnd: Cardinal; hIcon: HICON; pszDescription: LPCWSTR); safecall; + procedure SetThumbnailTooltip(hwnd: Cardinal; pszTip: LPCWSTR); safecall; + function SetThumbnailClip(hwnd: Cardinal; prcClip: PRect):Cardinal; safecall; + end; + +implementation + +end. diff --git a/Source/Windows7/dwTaskbarThumbnails.pas b/Source/Windows7/dwTaskbarThumbnails.pas new file mode 100644 index 0000000..c28ecca --- /dev/null +++ b/Source/Windows7/dwTaskbarThumbnails.pas @@ -0,0 +1,410 @@ +unit dwTaskbarThumbnails; + +interface + +uses + Classes, Messages, ImgList, AppEvnts, Windows, + dwTaskbarComponents, dwTaskbarList; + +type + TdwTaskbarThumbnails = class; + TdwTaskbarThumbnailList = class; + TdwTaskbarThumbnailItem = class; + + TOnThumbnailClick = procedure(Sender: TdwTaskbarThumbnailItem) of object; + + TdwTaskbarThumbnailItem = class(TCollectionItem) + private + FImageIndex: Integer; + FHint: WideString; + FEnabled: Boolean; + FShowBorder: Boolean; + FDismissOnClick: Boolean; + FVisible: Boolean; + FTag: Integer; + procedure SetImageIndex(const Value: Integer); + procedure SetHint(const Value: WideString); + procedure SetEnabled(const Value: Boolean); + procedure SetShowBorder(const Value: Boolean); + procedure SetDismissOnClick(const Value: Boolean); + procedure SetVisible(const Value: Boolean); + protected + public + constructor Create(Collection: TCollection); override; + procedure Assign(Source: TPersistent); override; + published + property ImageIndex: Integer read FImageIndex write SetImageIndex; + property Hint: WideString read FHint write SetHint; + property Enabled: Boolean read FEnabled write SetEnabled default True; + property ShowBorder: Boolean read FShowBorder write SetShowBorder default True; + property DismissOnClick: Boolean read FDismissOnClick write SetDismissOnClick default False; + property Visible: Boolean read FVisible write SetVisible default True; + property Tag: Integer read FTag write FTag default 0; + end; + + TdwTaskbarThumbnailList = class(TCollection) + private + FTaskbarThumbnails: TdwTaskbarThumbnails; + function GetItem(Index: Integer): TdwTaskbarThumbnailItem; + procedure SetItem(Index: Integer; Value: TdwTaskbarThumbnailItem); + protected + function GetOwner: TPersistent; override; + procedure Update(Item: TCollectionItem); override; + public + constructor Create(TaskbarThumbnails: TdwTaskbarThumbnails); + function Add: TdwTaskbarThumbnailItem; + function AddItem(Item: TdwTaskbarThumbnailItem; Index: Integer): TdwTaskbarThumbnailItem; + function Insert(Index: Integer): TdwTaskbarThumbnailItem; + property Items[Index: Integer]: TdwTaskbarThumbnailItem read GetItem write SetItem; default; + end; + + TdwTaskbarThumbnails = class(TdwTaskbarComponent) + private + FAppEvents: TApplicationEvents; + + FImages: TCustomImageList; + FThumbnails: TdwTaskbarThumbnailList; + FOnThumbnailClick: TOnThumbnailClick; + procedure SetImages(const Value: TCustomImageList); + procedure UpdateThumbnail(Index: Integer); + procedure UpdateThumbnails; + procedure SetThumbnails(const Value: TdwTaskbarThumbnailList); + function GetThumbButtons: TThumbButtonList; + procedure DoAppMessage(var Msg: TMsg; var Handled: Boolean); + protected + function DoInitialize: Boolean; override; + procedure DoUpdate; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + + procedure ShowThumbnails; + function ClipThumbnail(window:Cardinal; left:integer; right:integer; top:integer; bottom:integer):cardinal; + published + property AutoInitialize; + property Images: TCustomImageList read FImages write SetImages; + property Thumbnails: TdwTaskbarThumbnailList read FThumbnails write SetThumbnails; + property OnThumbnailClick: TOnThumbnailClick read FOnThumbnailClick write FOnThumbnailClick; + end; + +implementation + +uses + SysUtils, Graphics; + +{ TdwTaskbarThumbnailItem } + +procedure TdwTaskbarThumbnailItem.Assign(Source: TPersistent); +begin + if Source is TdwTaskbarThumbnailItem then + begin + Self.FImageIndex := (Source as TdwTaskbarThumbnailItem).FImageIndex; + Self.FHint := (Source as TdwTaskbarThumbnailItem).FHint; + Self.FEnabled := (Source as TdwTaskbarThumbnailItem).FEnabled; + Self.FShowBorder := (Source as TdwTaskbarThumbnailItem).FShowBorder; + Self.FDismissOnClick := (Source as TdwTaskbarThumbnailItem).FDismissOnClick; + Self.FVisible := (Source as TdwTaskbarThumbnailItem).FVisible; + Self.FTag := (Source as TdwTaskbarThumbnailItem).FTag; + end + else + begin + inherited Assign(Source); + end; +end; + +constructor TdwTaskbarThumbnailItem.Create(Collection: TCollection); +begin + inherited Create(Collection); + + FImageIndex := Index; + FHint := ''; + FEnabled := True; + FShowBorder := True; + FDismissOnClick := False; + FVisible := True; + FTag := 0; +end; + +procedure TdwTaskbarThumbnailItem.SetDismissOnClick(const Value: Boolean); +begin + if FDismissOnClick <> Value then + begin + FDismissOnClick := Value; + Changed(False); + end; +end; + +procedure TdwTaskbarThumbnailItem.SetEnabled(const Value: Boolean); +begin + if FEnabled <> Value then + begin + FEnabled := Value; + Changed(False); + end; +end; + +procedure TdwTaskbarThumbnailItem.SetHint(const Value: WideString); +begin + if FHint <> Value then + begin + FHint := Value; + Changed(False); + end; +end; + +procedure TdwTaskbarThumbnailItem.SetImageIndex(const Value: Integer); +begin + if FImageIndex <> Value then + begin + FImageIndex := Value; + Changed(False); + end; +end; + +procedure TdwTaskbarThumbnailItem.SetShowBorder(const Value: Boolean); +begin + if FShowBorder <> Value then + begin + FShowBorder := Value; + Changed(False); + end; +end; + +procedure TdwTaskbarThumbnailItem.SetVisible(const Value: Boolean); +begin + if FVisible <> Value then + begin + FVisible := Value; + Changed(False); + end; +end; + +{ TdwTaskbarThumbnailList } + +function TdwTaskbarThumbnailList.Add: TdwTaskbarThumbnailItem; +begin + FTaskbarThumbnails.CheckInitalization; + + Result := AddItem(nil, -1); +end; + +function TdwTaskbarThumbnailList.AddItem(Item: TdwTaskbarThumbnailItem; Index: Integer): TdwTaskbarThumbnailItem; +begin + FTaskbarThumbnails.CheckInitalization; + + if Item = nil then + begin + Result := TdwTaskbarThumbnailItem.Create(Self); + end + else + begin + Result := Item; + if Assigned(Item) then + begin + Result.Collection := Self; + if Index < Count then + Index := Count - 1; + Result.Index := Index; + end; + end; +end; + +constructor TdwTaskbarThumbnailList.Create(TaskbarThumbnails: TdwTaskbarThumbnails); +begin + inherited Create(TdwTaskbarThumbnailItem); + FTaskbarThumbnails := TaskbarThumbnails; +end; + +function TdwTaskbarThumbnailList.GetItem(Index: Integer): TdwTaskbarThumbnailItem; +begin + Result := TdwTaskbarThumbnailItem(inherited GetItem(Index)); +end; + +function TdwTaskbarThumbnailList.GetOwner: TPersistent; +begin + Result := FTaskbarThumbnails; +end; + +function TdwTaskbarThumbnailList.Insert(Index: Integer): TdwTaskbarThumbnailItem; +begin + FTaskbarThumbnails.CheckInitalization; + + Result := AddItem(nil, Index); +end; + +procedure TdwTaskbarThumbnailList.SetItem(Index: Integer; Value: TdwTaskbarThumbnailItem); +begin + inherited SetItem(Index, Value); +end; + +procedure TdwTaskbarThumbnailList.Update(Item: TCollectionItem); +begin + if Item <> nil then + FTaskbarThumbnails.UpdateThumbnail(Item.Index) + else + FTaskbarThumbnails.UpdateThumbnails; +end; + +{ TdwTaskbarThumbnails } + +constructor TdwTaskbarThumbnails.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + + FThumbnails := TdwTaskbarThumbnailList.Create(Self); + + FAppEvents := TApplicationEvents.Create(Self); + FAppEvents.OnMessage := DoAppMessage; +end; + +destructor TdwTaskbarThumbnails.Destroy; +begin + FThumbnails.Free; + FAppEvents.Free; + + inherited; +end; + +procedure TdwTaskbarThumbnails.DoAppMessage(var Msg: TMsg; var Handled: Boolean); +begin + if Msg.hwnd = TaskBarEntryHandle then + if Msg.message = WM_COMMAND then + if HiWord(Msg.wParam) = THBN_CLICKED then + begin + Handled := True; + if Assigned(FOnThumbnailClick) then + FOnThumbnailClick(FThumbnails[LoWord(Msg.wParam)]); + end; +end; + +function TdwTaskbarThumbnails.ClipThumbnail(window:Cardinal; left:integer; right:integer; top:integer; bottom:integer):cardinal; +var + rect:TRect; + rectp:PRect; +begin + //rect:=TRect.Create; + rect.Left := left; + rect.Top := top; + rect.Right := right; + rect.Bottom := bottom; + rectp:=@rect; + if (TaskbarList3<>nil) then + Result := TaskbarList3.SetThumbnailClip(window, rectp) + else + Result := 16777216; +end; + +function TdwTaskbarThumbnails.DoInitialize: Boolean; +var + Buttons: TThumbButtonList; +begin + SetLength(Buttons, 0); + if CheckWin32Version(6, 1) and (TaskbarList3 <> nil) then + begin + Buttons := GetThumbButtons; + if TaskbarList3 <> nil then + begin + TaskbarList3.ThumbBarSetImageList(TaskBarEntryHandle, FImages.Handle); + TaskbarList3.ThumbBarAddButtons(TaskBarEntryHandle, Length(Buttons), @Buttons[0]); + Result := True; + end + else + begin + Result := False; + end; + end + else + begin + Result := False; + end; +end; + +procedure TdwTaskbarThumbnails.DoUpdate; +var + Buttons: TThumbButtonList; +begin + SetLength(Buttons, 0); + if not IsInitialized then + Exit; + + Buttons := GetThumbButtons; + TaskbarList3.ThumbBarSetImageList(TaskBarEntryHandle, FImages.Handle); + TaskbarList3.ThumbBarUpdateButtons(TaskBarEntryHandle, Length(Buttons), @Buttons[0]); +end; + +function TdwTaskbarThumbnails.GetThumbButtons: TThumbButtonList; +var + I: Integer; + Thumb: TdwTaskbarThumbnailItem; +begin + if (FThumbnails.Count < 1) or (FThumbnails.Count > 7) then + raise Exception.Create('The thumbnail count must be at least 1 and can be up to 7.'); + + SetLength(Result, FThumbnails.Count); + for I := 0 to FThumbnails.Count - 1 do + begin + Thumb := FThumbnails[I]; + + Result[I].dwMask := THB_FLAGS; + + Result[I].iId := Thumb.Index; + + if FImages <> nil then + if (Thumb.ImageIndex >= 0) and (Thumb.ImageIndex < FImages.Count) then + begin + Result[I].dwMask := Result[I].dwMask or THB_BITMAP; + Result[I].iBitmap := Thumb.ImageIndex; + end; + + if Thumb.FHint <> '' then + begin + Result[I].dwMask := Result[I].dwMask or THB_TOOLTIP; + StringToWideChar(Thumb.Hint, Result[I].szTip, Length(Result[I].szTip)); + end; + + Result[I].dwFlags := 0; + if Thumb.FEnabled then + Result[I].dwFlags := Result[I].dwFlags or THBF_ENABLED + else + Result[I].dwFlags := Result[I].dwFlags or THBF_DISABLED; + + if not Thumb.FShowBorder then + Result[I].dwFlags := Result[I].dwFlags or THBF_NOBACKGROUND; + + if Thumb.DismissOnClick then + Result[I].dwFlags := Result[I].dwFlags or THBF_DISMISSONCLICK; + + if not Thumb.Visible then + Result[I].dwFlags := Result[I].dwFlags or THBF_HIDDEN; + end; +end; + +procedure TdwTaskbarThumbnails.SetImages(const Value: TCustomImageList); +begin + FImages := Value; + SendUpdateMessage; +end; + +procedure TdwTaskbarThumbnails.SetThumbnails(const Value: TdwTaskbarThumbnailList); +begin + FThumbnails.Assign(Value); + SendUpdateMessage; +end; + +procedure TdwTaskbarThumbnails.ShowThumbnails; +begin + CheckInitalization; + DoInitialize; +end; + +procedure TdwTaskbarThumbnails.UpdateThumbnail(Index: Integer); +begin + SendUpdateMessage; +end; + +procedure TdwTaskbarThumbnails.UpdateThumbnails; +begin + SendUpdateMessage; +end; + +end.