mirror-github-bspeice/apophysis7x
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

ADMIN: migration complete

Browse Source 
git-svn-id: https://svn.code.sf.net/p/apophysis7x/svn/trunk@1 a5d1c0f9-a0e9-45c6-87dd-9d276e40c949
This commit is contained in:
xyrus02
2013-07-28 08:58:33 +00:00
commit 95a2f54683
258 changed files with 175238 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

267
IO/Base64.pas Normal file
View File

@ -0,0 +1,267 @@
{
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 Base64;
interface
uses
Windows, Sysutils;
type TBinArray = Array of Byte;
{ Base64 encode and decode a string }
function B64Encode(const data: TBinArray; size : integer): string;
procedure B64Decode(S: string; var data : TBinArray; var size : integer);
{******************************************************************************}
{******************************************************************************}
implementation
const
B64Table= 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
procedure StringToBinArray(const s: String; var bin: TBinArray);
var
l: Integer;
begin
l := Length(s);
SetLength(bin, l);
CopyMemory(@bin[0], @s[1], l);
end;
procedure BinArrayToString(const bin: TBinArray; var s: string);
var
l: Integer;
begin
l := Length(bin);
SetLength(s, l);
CopyMemory(@s[1], @bin[0], l);
end;
function B64Encode(const data: TBinArray; size : integer) : string;
var
i: integer;
S: string;
InBuf: array[0..2] of byte;
OutBuf: array[0..3] of char;
begin
BinArrayToString(data, s);
SetLength(Result,((size+2) div 3)*4);
for i:= 1 to ((size+2) div 3) do
begin
if size< (i*3) then
Move(S[(i-1)*3+1],InBuf,size-(i-1)*3)
else
Move(S[(i-1)*3+1],InBuf,3);
OutBuf[0]:= B64Table[((InBuf[0] and $FC) shr 2) + 1];
OutBuf[1]:= B64Table[(((InBuf[0] and $03) shl 4) or ((InBuf[1] and $F0) shr 4)) + 1];
OutBuf[2]:= B64Table[(((InBuf[1] and $0F) shl 2) or ((InBuf[2] and $C0) shr 6)) + 1];
OutBuf[3]:= B64Table[(InBuf[2] and $3F) + 1];
Move(OutBuf,Result[(i-1)*4+1],4);
end;
if (size mod 3)= 1 then
begin
Result[Length(Result)-1]:= '=';
Result[Length(Result)]:= '=';
end
else if (Length(S) mod 3)= 2 then
Result[Length(Result)]:= '=';
end;
procedure B64Decode(S: string; var data : TBinArray; var size : integer);
var
i: integer;
InBuf: array[0..3] of byte;
OutBuf: array[0..2] of byte;
Result2: string;
begin
if (Length(S) mod 4)<> 0 then
raise Exception.Create('Base64: Incorrect string format');
SetLength(Result2,((Length(S) div 4)-1)*3);
for i:= 1 to ((Length(S) div 4)-1) do
begin
Move(S[(i-1)*4+1],InBuf,4);
if (InBuf[0]> 64) and (InBuf[0]< 91) then
Dec(InBuf[0],65)
else if (InBuf[0]> 96) and (InBuf[0]< 123) then
Dec(InBuf[0],71)
else if (InBuf[0]> 47) and (InBuf[0]< 58) then
Inc(InBuf[0],4)
else if InBuf[0]= 43 then
InBuf[0]:= 62
else
InBuf[0]:= 63;
if (InBuf[1]> 64) and (InBuf[1]< 91) then
Dec(InBuf[1],65)
else if (InBuf[1]> 96) and (InBuf[1]< 123) then
Dec(InBuf[1],71)
else if (InBuf[1]> 47) and (InBuf[1]< 58) then
Inc(InBuf[1],4)
else if InBuf[1]= 43 then
InBuf[1]:= 62
else
InBuf[1]:= 63;
if (InBuf[2]> 64) and (InBuf[2]< 91) then
Dec(InBuf[2],65)
else if (InBuf[2]> 96) and (InBuf[2]< 123) then
Dec(InBuf[2],71)
else if (InBuf[2]> 47) and (InBuf[2]< 58) then
Inc(InBuf[2],4)
else if InBuf[2]= 43 then
InBuf[2]:= 62
else
InBuf[2]:= 63;
if (InBuf[3]> 64) and (InBuf[3]< 91) then
Dec(InBuf[3],65)
else if (InBuf[3]> 96) and (InBuf[3]< 123) then
Dec(InBuf[3],71)
else if (InBuf[3]> 47) and (InBuf[3]< 58) then
Inc(InBuf[3],4)
else if InBuf[3]= 43 then
InBuf[3]:= 62
else
InBuf[3]:= 63;
OutBuf[0]:= (InBuf[0] shl 2) or ((InBuf[1] shr 4) and $03);
OutBuf[1]:= (InBuf[1] shl 4) or ((InBuf[2] shr 2) and $0F);
OutBuf[2]:= (InBuf[2] shl 6) or (InBuf[3] and $3F);
Move(OutBuf,Result2[(i-1)*3+1],3);
end;
if Length(S)<> 0 then
begin
Move(S[Length(S)-3],InBuf,4);
if InBuf[2]= 61 then
begin
if (InBuf[0]> 64) and (InBuf[0]< 91) then
Dec(InBuf[0],65)
else if (InBuf[0]> 96) and (InBuf[0]< 123) then
Dec(InBuf[0],71)
else if (InBuf[0]> 47) and (InBuf[0]< 58) then
Inc(InBuf[0],4)
else if InBuf[0]= 43 then
InBuf[0]:= 62
else
InBuf[0]:= 63;
if (InBuf[1]> 64) and (InBuf[1]< 91) then
Dec(InBuf[1],65)
else if (InBuf[1]> 96) and (InBuf[1]< 123) then
Dec(InBuf[1],71)
else if (InBuf[1]> 47) and (InBuf[1]< 58) then
Inc(InBuf[1],4)
else if InBuf[1]= 43 then
InBuf[1]:= 62
else
InBuf[1]:= 63;
OutBuf[0]:= (InBuf[0] shl 2) or ((InBuf[1] shr 4) and $03);
Result2:= Result2 + char(OutBuf[0]);
end
else if InBuf[3]= 61 then
begin
if (InBuf[0]> 64) and (InBuf[0]< 91) then
Dec(InBuf[0],65)
else if (InBuf[0]> 96) and (InBuf[0]< 123) then
Dec(InBuf[0],71)
else if (InBuf[0]> 47) and (InBuf[0]< 58) then
Inc(InBuf[0],4)
else if InBuf[0]= 43 then
InBuf[0]:= 62
else
InBuf[0]:= 63;
if (InBuf[1]> 64) and (InBuf[1]< 91) then
Dec(InBuf[1],65)
else if (InBuf[1]> 96) and (InBuf[1]< 123) then
Dec(InBuf[1],71)
else if (InBuf[1]> 47) and (InBuf[1]< 58) then
Inc(InBuf[1],4)
else if InBuf[1]= 43 then
InBuf[1]:= 62
else
InBuf[1]:= 63;
if (InBuf[2]> 64) and (InBuf[2]< 91) then
Dec(InBuf[2],65)
else if (InBuf[2]> 96) and (InBuf[2]< 123) then
Dec(InBuf[2],71)
else if (InBuf[2]> 47) and (InBuf[2]< 58) then
Inc(InBuf[2],4)
else if InBuf[2]= 43 then
InBuf[2]:= 62
else
InBuf[2]:= 63;
OutBuf[0]:= (InBuf[0] shl 2) or ((InBuf[1] shr 4) and $03);
OutBuf[1]:= (InBuf[1] shl 4) or ((InBuf[2] shr 2) and $0F);
Result2:= Result2 + char(OutBuf[0]) + char(OutBuf[1]);
end
else
begin
if (InBuf[0]> 64) and (InBuf[0]< 91) then
Dec(InBuf[0],65)
else if (InBuf[0]> 96) and (InBuf[0]< 123) then
Dec(InBuf[0],71)
else if (InBuf[0]> 47) and (InBuf[0]< 58) then
Inc(InBuf[0],4)
else if InBuf[0]= 43 then
InBuf[0]:= 62
else
InBuf[0]:= 63;
if (InBuf[1]> 64) and (InBuf[1]< 91) then
Dec(InBuf[1],65)
else if (InBuf[1]> 96) and (InBuf[1]< 123) then
Dec(InBuf[1],71)
else if (InBuf[1]> 47) and (InBuf[1]< 58) then
Inc(InBuf[1],4)
else if InBuf[1]= 43 then
InBuf[1]:= 62
else
InBuf[1]:= 63;
if (InBuf[2]> 64) and (InBuf[2]< 91) then
Dec(InBuf[2],65)
else if (InBuf[2]> 96) and (InBuf[2]< 123) then
Dec(InBuf[2],71)
else if (InBuf[2]> 47) and (InBuf[2]< 58) then
Inc(InBuf[2],4)
else if InBuf[2]= 43 then
InBuf[2]:= 62
else
InBuf[2]:= 63;
if (InBuf[3]> 64) and (InBuf[3]< 91) then
Dec(InBuf[3],65)
else if (InBuf[3]> 96) and (InBuf[3]< 123) then
Dec(InBuf[3],71)
else if (InBuf[3]> 47) and (InBuf[3]< 58) then
Inc(InBuf[3],4)
else if InBuf[3]= 43 then
InBuf[3]:= 62
else
InBuf[3]:= 63;
OutBuf[0]:= (InBuf[0] shl 2) or ((InBuf[1] shr 4) and $03);
OutBuf[1]:= (InBuf[1] shl 4) or ((InBuf[2] shr 2) and $0F);
OutBuf[2]:= (InBuf[2] shl 6) or (InBuf[3] and $3F);
Result2:= Result2 + Char(OutBuf[0]) + Char(OutBuf[1]) + Char(OutBuf[2]);
end;
end;
StringToBinArray(Result2, data);
size := Length(result2);
end;
end.

177
IO/Binary.pas Normal file
View File

@ -0,0 +1,177 @@
unit Binary;
interface
const
HIB_BLOCKSIZE = $10; // 16 bytes
HIB_MAXOFFSET = $0F; // HIB_BLOCKSIZE - 1
type
// low-level binary types
TBlock = array[0..HIB_MAXOFFSET] of byte;
TWord = array[0..1] of byte;
TDWord = array[0..3] of byte;
TQWord = array[0..7] of byte;
THibRawString = array of byte;
// procedures to write blocks at low level
procedure WriteData2(var target: TBlock; data: TWord; pos: integer);
procedure WriteData4(var target: TBlock; data: TDWord; pos: integer);
procedure WriteData8(var target: TBlock; data: TQWord; pos: integer);
// procedures to read blocks at low level
procedure ReadData2(source: TBlock; var data: TWord; pos: integer);
procedure ReadData4(source: TBlock; var data: TDWord; pos: integer);
procedure ReadData8(source: TBlock; var data: TQWord; pos: integer);
// procedures to write typed data to blocks
procedure Int16ToBlock(var target: TBlock; pos: integer; data: SmallInt);
procedure Int32ToBlock(var target: TBlock; pos: integer; data: Integer);
procedure LongWordToBlock(var target: TBlock; pos: integer; data: LongWord);
procedure Int64ToBlock(var target: TBlock; pos: integer; data: Int64);
procedure SingleToBlock(var target: TBlock; pos: integer; data: Single);
procedure DoubleToBlock(var target: TBlock; pos: integer; data: Double);
// procedures to read typed data from blocks
function BlockToInt16(source: TBlock; pos: integer): SmallInt;
function BlockToInt32(source: TBlock; pos: integer): Integer;
function BlockToLongWord(source: TBlock; pos: integer): LongWord;
function BlockToInt64(source: TBlock; pos: integer): Int64;
function BlockToSingle(source: TBlock; pos: integer): Single;
function BlockToDouble(source: TBlock; pos: integer): Double;
implementation
procedure ReadData2(source: TBlock; var data: TWord; pos: integer);
const size = 2;
var i: integer;
begin
for i := 0 to size - 1 do
if i + pos < HIB_BLOCKSIZE then
data[i] := source[i + pos];
end;
procedure ReadData4(source: TBlock; var data: TDWord; pos: integer);
const size = 4;
var i: integer;
begin
for i := 0 to size - 1 do
if i + pos < HIB_BLOCKSIZE then
data[i] := source[i + pos];
end;
procedure ReadData8(source: TBlock; var data: TQWord; pos: integer);
const size = 8;
var i: integer;
begin
for i := 0 to size - 1 do
if i + pos < HIB_BLOCKSIZE then
data[i] := source[i + pos];
end;
procedure WriteData2(var target: TBlock; data: TWord; pos: integer);
const size = 2;
var i: integer;
begin
for i := 0 to size - 1 do
if i + pos < HIB_BLOCKSIZE then
target[i + pos] := data[i];
end;
procedure WriteData4(var target: TBlock; data: TDWord; pos: integer);
const size = 4;
var i: integer;
begin
for i := 0 to size - 1 do
if i + pos < HIB_BLOCKSIZE then
target[i + pos] := data[i];
end;
procedure WriteData8(var target: TBlock; data: TQWord; pos: integer);
const size = 8;
var i: integer;
begin
for i := 0 to size - 1 do
if i + pos < HIB_BLOCKSIZE then
target[i + pos] := data[i];
end;
function BlockToInt16(source: TBlock; pos: integer): SmallInt;
var temp: TWord; data: SmallInt;
begin
ReadData2(source, temp, pos);
Move(temp, data, SizeOf(TWord));
Result := data;
end;
function BlockToInt32(source: TBlock; pos: integer): Integer;
var temp: TDWord; data: Integer;
begin
ReadData4(source, temp, pos);
Move(temp, data, SizeOf(TDWord));
Result := data;
end;
function BlockToLongWord(source: TBlock; pos: integer): LongWord;
var temp: TDWord; data: LongWord;
begin
ReadData4(source, temp, pos);
Move(temp, data, SizeOf(TDWord));
Result := data;
end;
function BlockToInt64(source: TBlock; pos: integer): Int64;
var temp: TQWord; data: Int64;
begin
ReadData8(source, temp, pos);
Move(temp, data, SizeOf(TQWord));
Result := data;
end;
function BlockToSingle(source: TBlock; pos: integer): Single;
var temp: TDWord; data: Single;
begin
ReadData4(source, temp, pos);
Move(temp, data, SizeOf(TDWord));
Result := data;
end;
function BlockToDouble(source: TBlock; pos: integer): Double;
var temp: TQWord; data: Double;
begin
ReadData8(source, temp, pos);
Move(temp, data, SizeOf(TQWord));
Result := data;
end;
procedure Int16ToBlock(var target: TBlock; pos: integer; data: SmallInt);
var temp: TWord;
begin
Move(data, temp, SizeOf(TWord));
WriteData2(target, temp, pos);
end;
procedure Int32ToBlock(var target: TBlock; pos: integer; data: Integer);
var temp: TDWord;
begin
Move(data, temp, SizeOf(TDWord));
WriteData4(target, temp, pos);
end;
procedure LongWordToBlock(var target: TBlock; pos: integer; data: LongWord);
var temp: TDWord;
begin
Move(data, temp, SizeOf(TDWord));
WriteData4(target, temp, pos);
end;
procedure Int64ToBlock(var target: TBlock; pos: integer; data: Int64);
var temp: TQWord;
begin
Move(data, temp, SizeOf(TQWord));
WriteData8(target, temp, pos);
end;
procedure SingleToBlock(var target: TBlock; pos: integer; data: single);
var temp: TDWord;
begin
Move(data, temp, SizeOf(TDWord));
WriteData4(target, temp, pos);
end;
procedure DoubleToBlock(var target: TBlock; pos: integer; data: double);
var temp: TQWord;
begin
Move(data, temp, SizeOf(TQWord));
WriteData8(target, temp, pos);
end;
end.

48
IO/CommandLine.pas Normal file
View File

@ -0,0 +1,48 @@
unit CommandLine;
interface
uses Dialogs, RegularExpressionsCore;
type TCommandLine = class
public
CreateFromTemplate : boolean;
TemplateFile : string;
TemplateName : string;
Lite: boolean;
procedure Load;
end;
implementation
procedure TCommandLine.Load;
var
Regex: TPerlRegEx;
begin
Regex := TPerlRegEx.Create;
Regex.RegEx := '-template\s+"(.+)"\s+"(.+)"';
Regex.Options := [preSingleLine, preCaseless];
Regex.Subject := Utf8String(CmdLine);
CreateFromTemplate := false;
if Regex.Match then begin
if Regex.GroupCount = 2 then begin
CreateFromTemplate := true;
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.

397
IO/Hibernation.pas Normal file
View File

@ -0,0 +1,397 @@
unit Hibernation;
interface
uses RenderingCommon, RenderingInterface, SysUtils, Windows, Forms, Classes, Binary, ControlPoint;
const
HIB_VERSION_MAJOR = 2; // Apophysis7X.15
HIB_VERSION_MINOR = 10;
HIB_VERSION_REVISION = 1500;
HIB_ADDR_HEADER = $30; // 48 bytes
HIB_SIZE_HEADER = $30; // 48 bytes
HIB_ADDR_LOCATOR = $60; // HIB_SIZE_HEADER + HIB_ADDR_HEADER
HIB_SIZE_LOCATOR = $20; // 32 bytes
HIB_COOKIE_INTRO_HIGH = $AB; // A B0F
HIB_COOKIE_INTRO_LOW = $0F;
HIB_COOKIE_OUTRO_HIGH = $AE; // A E0F
HIB_COOKIE_OUTRO_LOW = $0F;
type
EHibBitsPerPixel = (
EBP_32 = 32,
EBP_64 = 64 // 64 bit renderer; probably used later
);
EHibPixelLayout = (
EPL_XYZW = 0123,
EPL_YXZW = 1023, // indicates different subpixel orders;
EPL_YZXW = 1203, // for example, metaphysis uses WXYZ (3012)
EPL_YZWX = 1230,
EPL_XZYW = 0213,
EPL_XZWY = 0231,
EPL_XYWZ = 0132,
EPL_ZXYW = 2013,
EPL_WXYZ = 3012,
EPL_XWYZ = 0312
);
EHibFileFlags = (
EFF_NONE = 0, // no flags (default)
EFF_FLOATBUFFER = 1, // using a float buffer (32/64bit)
EFF_SEPARATEFLAME = 2, // flame stored in separate file (unused yet)
EFF_BINARYFLAME = 4, // flame stored in binary format (unused yet)
EFF_COMPRESSED = 8 // data is GZIP-compressed (unused yet)
);
// some types for the header (some unused)
THibInt2_32 = record X, Y : integer; end;
THibInt2_64 = record X, Y : int64; end;
THibFloat2 = record X, Y : double; end;
THibFloat4 = record X, Y, Z, W : double; end;
THibBoolean = (HB_YES = -1, HB_NO = 0);
// the actual header
THibHeader = record
ActualDensity : double;
Size2D : THibInt2_64;
Size : int64;
RenderTime : TDateTime;
PauseTime : TDateTime;
end;
// file allocation and release procedures
procedure HibAllocate(var handle: File; path: string);
procedure HibOpen(var handle: File; path: string);
procedure HibFree(const handle: File);
// high-level write procedures
procedure HibWriteIntro(const handle: File);
procedure HibWriteOutro(const handle: File);
procedure HibWriteGlobals(const handle: File; flags: EHibFileFlags;
layout: EHibPixelLayout; bpp: EHibBitsPerPixel);
procedure HibWriteHeader(const handle: File; header: THibHeader);
procedure HibWriteData(const handle: File; header: THibHeader;
flame: TControlPoint; buckets: TBucket32Array;
colormap: TColorMapArray; callback: TOnProgress);
// high-level read procedures
procedure HibReadIntro(const handle: File; var cookieValid: boolean);
procedure HibReadOutro(const handle: File; var cookieValid: boolean);
procedure HibReadGlobals(const handle: File; var versionRel: smallint;
var flags: EHibFileFlags; var layout: EHibPixelLayout; var bpp: EHibBitsPerPixel);
procedure HibReadHeader(const handle: File; var header: THibHeader);
procedure HibReadData(const handle: File; header: THibHeader; var flame: TStringList;
var buckets: TBucket32Array; var colormap: TColorMapArray; callback: TOnProgress);
implementation
////////////////////////////////////////////////////////////////////////////////
procedure HibAllocate(var handle: File; path: string);
begin
AssignFile(handle, path);
ReWrite(handle, HIB_BLOCKSIZE);
end;
procedure HibOpen(var handle: File; path: string);
begin
AssignFile(handle, path);
FileMode := fmOpenRead;
Reset(handle, HIB_BLOCKSIZE);
end;
procedure HibFree(const handle: File);
begin
CloseFile(handle);
end;
////////////////////////////////////////////////////////////////////////////////
procedure HibWriteIntro(const handle: File);
var
block: TBlock;
chunk: string;
begin
block[0] := HIB_COOKIE_INTRO_HIGH;
block[1] := HIB_COOKIE_INTRO_LOW;
chunk := 'Apophysis7X Hi';
CopyMemory(@block[2], @chunk[1], Length(chunk));
BlockWrite(handle, block, 1);
chunk := 'bernation File';
block[14] := $0; block[15] := $0;
CopyMemory(@block[0], @chunk[1], Length(chunk));
BlockWrite(handle, block, 1);
end;
procedure HibWriteOutro(const handle: File);
var
block: TBlock;
begin
block[0] := $0; block[1] := $0; block[2] := $0; block[3] := $0;
block[4] := $0; block[5] := $0; block[6] := $0; block[7] := $0;
block[8] := $0; block[9] := $0; block[10] := $0; block[11] := $0;
block[12] := $0; block[13] := $0;
block[14] := HIB_COOKIE_OUTRO_HIGH;
block[15] := HIB_COOKIE_OUTRO_LOW;
BlockWrite(handle, block, 1);
end;
procedure HibWriteGlobals(const handle: File; flags: EHibFileFlags;
layout: EHibPixelLayout; bpp: EHibBitsPerPixel);
var
block: TBlock;
begin
Int16ToBlock(block, 0, HIB_VERSION_MAJOR);
Int16ToBlock(block, 2, HIB_VERSION_MINOR);
Int32ToBlock(block, 4, HIB_VERSION_REVISION);
Int16ToBlock(block, 8, SmallInt(flags));
Int16ToBlock(block, 10, HIB_SIZE_HEADER);
Int16ToBlock(block, 12, SmallInt(layout));
Int16ToBlock(block, 14, SmallInt(bpp));
BlockWrite(handle, block, 1);
end;
procedure HibWriteHeader(const handle: File; header: THibHeader);
var
block: TBlock;
begin
DoubleToBlock(block, 0, header.ActualDensity);
Int64ToBlock(block, 8, header.Size);
BlockWrite(handle, block, 1);
Int64ToBlock(block, 0, header.Size2D.X);
Int64ToBlock(block, 8, header.Size2D.Y);
BlockWrite(handle, block, 1);
Int64ToBlock(block, 0,
Int64(((Trunc(header.RenderTime) - 25569) * 86400) +
Trunc(86400 * (header.RenderTime -
Trunc(header.RenderTime))) - 7200));
Int64ToBlock(block, 8,
Int64(((Trunc(header.PauseTime) - 25569) * 86400) +
Trunc(86400 * (header.PauseTime -
Trunc(header.PauseTime))) - 7200));
BlockWrite(handle, block, 1);
end;
procedure HibWriteData(const handle: File; header: THibHeader; flame: TControlPoint;
buckets: TBucket32Array; colormap: TColorMapArray; callback: TOnProgress);
var
block: TBlock;
flametext: string;
rawflame: THibRawString;
rawflamesize: integer;
rawflamechunks: integer;
i, j, c: integer;
p, step: double;
begin
rawflamesize := CalcBinaryFlameSize(flame);
Int64ToBlock(block, 0, HIB_ADDR_LOCATOR + HIB_SIZE_LOCATOR);
Int64ToBlock(block, 8, Int64(rawflamesize) );
BlockWrite(handle, block, 1);
Int64ToBlock(block, 0, HIB_ADDR_LOCATOR + HIB_SIZE_LOCATOR + rawflamesize);
Int64ToBlock(block, 8, 16 * header.Size2D.X * header.Size2D.Y);
BlockWrite(handle, block, 1);
flame.SaveToBinary(handle);
callback(0);
c := 0; p := 0;
step := 1.0 / (header.Size2D.X * header.Size2D.Y);
for j := 0 to header.Size2D.Y - 1 do
for i := 0 to header.Size2D.X - 1 do
with buckets[j][i] do begin
Int32ToBlock(block, 0, Red);
Int32ToBlock(block, 4, Green);
Int32ToBlock(block, 8, Blue);
Int32ToBlock(block, 12, Count);
BlockWrite(handle, block, 1);
p := p + step;
c := (c + 1) mod 64;
if (c = 0) then begin
callback(p*0.99);
Application.ProcessMessages;
end;
end;
callback(0.99);
i := 0;
while i < 256 do begin
Int32ToBlock(block, 0,
(colormap[i+0].Red) or
(((colormap[i+0].Green) and $ff) shl 8) or
(((colormap[i+0].Blue) and $ff) shl 16));
Int32ToBlock(block, 4,
(colormap[i+1].Red) or
(((colormap[i+1].Green) and $ff) shl 8) or
(((colormap[i+1].Blue) and $ff) shl 16));
Int32ToBlock(block, 8,
(colormap[i+2].Red) or
(((colormap[i+2].Green) and $ff) shl 8) or
(((colormap[i+2].Blue) and $ff) shl 16));
Int32ToBlock(block, 12,
(colormap[i+3].Red) or
(((colormap[i+3].Green) and $ff) shl 8) or
(((colormap[i+3].Blue) and $ff) shl 16));
BlockWrite(handle, block, 1);
i := i + 4;
end;
callback(1);
end;
////////////////////////////////////////////////////////////////////////////////
procedure HibReadIntro(const handle: File; var cookieValid: boolean);
var
block1, block2: TBlock;
begin
BlockRead(handle, block1, 1);
BlockRead(handle, block2, 1);
cookieValid :=
(block1[0] = HIB_COOKIE_INTRO_HIGH) and
(block1[1] = HIB_COOKIE_INTRO_LOW);
end;
procedure HibReadOutro(const handle: File; var cookieValid: boolean);
var
block1, block2: TBlock;
begin
BlockRead(handle, block1, 1);
BlockRead(handle, block2, 1);
cookieValid :=
(block2[14] = HIB_COOKIE_OUTRO_HIGH) and
(block2[15] = HIB_COOKIE_OUTRO_LOW);
end;
procedure HibReadGlobals(const handle: File; var versionRel: SmallInt;
var flags: EHibFileFlags; var layout: EHibPixelLayout; var bpp: EHibBitsPerPixel);
var
block: TBlock;
major, minor, rev: Integer;
begin
BlockRead(handle, block, 1);
major := BlockToInt16(block, 0);
minor := BlockToInt16(block, 2);
rev := BlockToInt32(block, 4);
flags := EHibFileFlags(BlockToInt16(block, 8));
assert(BlockToInt16(block, 10) <> HIB_SIZE_HEADER, 'Invalid header size');
layout := EHibPixelLayout(BlockToInt16(block, 12));
bpp := EHibBitsPerPixel(BlockToInt16(block, 14));
if major < HIB_VERSION_MAJOR then versionRel := -1
else if major > HIB_VERSION_MAJOR then versionRel := 1
else begin
if minor < HIB_VERSION_MINOR then versionRel := -1
else if minor > HIB_VERSION_MINOR then versionRel := 1
else begin
if rev < HIB_VERSION_REVISION then versionRel := -1
else if rev > HIB_VERSION_REVISION then versionRel := 1
else versionRel := 0;
end;
end;
end;
procedure HibReadHeader(const handle: File; var header: THibHeader);
var
block: TBlock;
begin
BlockRead(handle, block, 1);
header.ActualDensity := BlockToDouble(block, 0);
header.Size := BlockToInt64(block, 8);
BlockRead(handle, block, 1);
header.Size2D.X := BlockToInt64(block, 0);
header.Size2D.Y := BlockToInt64(block, 8);
BlockRead(handle, block, 1);
header.RenderTime := ((BlockToInt64(block, 0) + 7200) / 86500) + 25569;
header.PauseTime := ((BlockToInt64(block, 8) + 7200) / 86500) + 25569;
end;
procedure HibReadData(const handle: File; header: THibHeader; var flame: TStringList;
var buckets: TBucket32Array; var colormap: TColorMapArray; callback: TOnProgress);
var
block: TBlock;
pos, offsf, sizef, offsd, sized : Int64;
fbytes: THibRawString;
i, c, bx, by: Integer;
p, step: Double;
begin
BlockRead(handle, block, 1);
offsf := BlockToInt64(block, 0);
sizef := BlockToInt64(block, 8);
BlockRead(handle, block, 1);
offsd := BlockToInt64(block, 0);
sized := BlockToInt64(block, 8);
pos := 0;
Seek(handle, offsf);
SetLength(fbytes, sizef);
while pos < sizef do begin
BlockRead(handle, block, 1);
CopyMemory(@fbytes[pos], @block[0], HIB_BLOCKSIZE);
pos := pos + HIB_BLOCKSIZE;
end;
flame := TStringList.Create;
flame.Text := PChar(fbytes);
pos := 0;
bx := 0; by := 0;
Seek(handle, offsd);
SetLength(buckets, header.Size2D.Y, header.Size2D.X);
callback(0);
c := 0; p := 0;
step := 1.0 / sized;
while pos < sized do begin
with buckets[by][bx] do begin
BlockRead(handle, block, 1);
Red := BlockToInt32(block, 0);
Green := BlockToInt32(block, 4);
Blue := BlockToInt32(block, 8);
Count := BlockToInt32(block, 12);
end;
Inc(bx);
pos := pos + HIB_BLOCKSIZE;
if bx >= header.Size2D.X then begin
Inc(by); bx := 0;
end;
p := p + step;
c := (c + 1) mod 64;
if (c = 0) then begin
callback(p*0.99);
Application.ProcessMessages;
end;
end;
callback(0.99);
i := 0;
while i < 256 do begin
BlockRead(handle, block, 1);
c := BlockToInt32(block, 0);
colormap[i+0].Red := c and $ff;
colormap[i+0].Green := (c and $ff00) shr 8;
colormap[i+0].Blue := (c and $ff0000) shr 16;
c := BlockToInt32(block, 4);
colormap[i+1].Red := c and $ff;
colormap[i+1].Green := (c and $ff00) shr 8;
colormap[i+1].Blue := (c and $ff0000) shr 16;
c := BlockToInt32(block, 8);
colormap[i+2].Red := c and $ff;
colormap[i+2].Green := (c and $ff00) shr 8;
colormap[i+2].Blue := (c and $ff0000) shr 16;
c := BlockToInt32(block, 12);
colormap[i+3].Red := c and $ff;
colormap[i+3].Green := (c and $ff00) shr 8;
colormap[i+3].Blue := (c and $ff0000) shr 16;
i := i + 4;
end;
end;
end.

76
IO/MissingPlugin.pas Normal file
View File

@ -0,0 +1,76 @@
unit MissingPlugin;
interface
uses Windows, Global, Classes, LoadTracker, ComCtrls, SysUtils,
ControlPoint, Translation;
const RegisteredAttributes : array[0..13] of string = (
'weight', 'color', 'symmetry', 'color_speed', 'coefs', 'chaos',
'plotmode', 'opacity', 'post', 'var', 'var1', 'var_color',
'name', 'linear3D'
);
var MissingPluginList : TStringList;
Parsing : boolean;
ErrorMessageString : string;
procedure BeginParsing;
procedure CheckAttribute(attr:string);
function EndParsing(cp : TControlPoint; var statusPanelText : string): boolean;
procedure AnnoyUser;
implementation
procedure BeginParsing;
begin
MissingPluginList := TStringList.Create;
if (AutoOpenLog = true) then
if (LoadForm.Showing = false) then
LoadForm.Show;
end;
procedure CheckAttribute(attr:string);
var i : integer;
begin
for i := 0 to Length(RegisteredAttributes)-1 do
if attr=RegisteredAttributes[i] then exit;
if MissingPluginList.IndexOf(attr) < 0 then
MissingPluginList.Add(attr);
end;
function EndParsing(cp : TControlPoint; var statusPanelText : string): boolean;
var str, str2 : string; i : integer; newl : TStringList;
begin
str2 := TextByKey('main-status-variationsorvariables');
if (cp.used_plugins.Count > 0) then begin
newl := TStringList.Create;
for i := 0 to MissingPluginList.Count - 1 do begin
if cp.used_plugins.IndexOf(MissingPluginList[i]) >= 0 then
newl.Add(MissingPluginList[i]);
end;
str2 := TextByKey('main-status-plugins');
MissingPluginList.Free;
MissingPluginList := newl;
end;
if MissingPluginList.Count > 0 then begin
statusPanelText := Format(TextByKey('main-status-loadingerrorcount'), [MissingPluginList.Count]);
for i := 0 to MissingPluginList.Count - 1 do
str := str + #13#10 + ' - ' + MissingPluginList[i];
ErrorMessageString := Format(TextByKey('main-status-morepluginsneeded'), [cp.name, str2]) + str;
LoadForm.Output.Text := LoadForm.Output.Text +
ErrorMessageString + #13#10#13#10;
Result := false;
end else begin
statusPanelText := TextByKey('main-status-noloadingerrors');
ErrorMessageString := '';
Result := true;
end;
MissingPluginList.Free;
end;
procedure AnnoyUser;
begin
if (ErrorMessageString = '') or (not WarnOnMissingPlugin) then exit;
MessageBox($00000000, PChar(ErrorMessageString), PChar('Apophysis'), MB_ICONHAND or MB_OK);
end;
end.

603
IO/ParameterIO.pas Normal file
View File

@ -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 := '<flame.*?name="(.*?)".*?>.*?</flame>';
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 := '<flame.*?>.*?</flame>';
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 := '<flame.*?name="(.*?)".*?>.*?</flame>';
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 = '<flame(.*?)>(.*?)</flame>';
re_xform : string = '<((?:final)?xform)(.*?)/>';
re_palette : string = '<palette(.*?)>([a-f0-9\s]+)</palette>';
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 = '<palette(.*?)>([a-f0-9\s]+)</palette>';
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 := ' <palette count="256" format="RGB">';
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 + ' </palette>';
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('<flame name="' + cp1.name + '" ' + parameters + '>');
{ 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('</flame>');
xml := FileList.text;
result := true;
finally
FileList.free
end;
end;
end.

1545
IO/Settings.pas Normal file
View File

File diff suppressed because it is too large Load Diff