|
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755 |
- unit utsUtils;
-
- {$IFDEF FPC}
- {$mode objfpc}{$H+}
- {$ENDIF}
-
- interface
-
- uses
- Classes, SysUtils, Contnrs,
- utsTypes;
-
- type
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TtsRefManager = class(TObject)
- private
- fMasterRef: TtsRefManager; // master of this object (master will destroy this object)
- fSlaveRefs: TObjectList; // slaves of this object (will destroy all slaves when this objects is destroyed)
- protected
- procedure AddSlave(const aSlave: TtsRefManager); virtual;
- function DelSlave(const aSlave: TtsRefManager): Boolean; virtual;
- public
- constructor Create(const aMaster: TtsRefManager);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TtsMultiMasterRefManager = class(TtsRefManager)
- private
- fMasterRefs: TObjectList;
- public
- procedure AddMaster(const aMaster: TtsRefManager); virtual;
- procedure DelMaster(const aMaster: TtsRefManager); virtual;
-
- constructor Create(const aMaster: TtsRefManager);
- destructor Destroy; override;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TtsKernel1DItem = packed record
- Offset: Integer;
- Value: Single;
- end;
-
- TtsKernel1D = class
- public
- Size: Integer;
- Items: array of TtsKernel1DItem;
- ItemCount: Integer;
- constructor Create(const aRadius, aStrength: Single);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TtsKernel2DItem = packed record
- OffsetX: Integer;
- OffsetY: Integer;
- Value: Double;
- DataOffset: Integer;
- end;
-
- TtsKernel2D = class
- public
- SizeX: Integer;
- SizeY: Integer;
-
- MidSizeX: Integer;
- MidSizeY: Integer;
-
- ValueSum: Double;
-
- Items: array of TtsKernel2DItem;
- ItemCount: Integer;
-
- constructor Create(const aRadius, aStrength: Single);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- EtsException = class(Exception);
- EtsRenderer = class(EtsException);
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsColor4f(r, g, b, a: Single): TtsColor4f;
- function tsPosition(const x, y: Integer): TtsPosition;
- function tsRect(const l, t, r, b: Integer): TtsRect; overload;
- function tsRect(const aTopLeft, aBottomRight: TtsPosition): TtsRect; overload;
- function tsVector4f(X, Y, Z, W: Single): TtsVector4f;
- function tsMatrix4f(X, Y, Z, P: TtsVector4f): TtsMatrix4f;
-
- function tsFormatSize(const aFormat: TtsFormat): Integer;
- procedure tsFormatMap(const aFormat: TtsFormat; var aData: PByte; const aColor: TtsColor4f);
- procedure tsFormatUnmap(const aFormat: TtsFormat; var aData: PByte; out aColor: TtsColor4f);
-
- function tsBlendValueIgnore(const aSrc, aDst: Single): Single;
- function tsBlendValueReplace(const aSrc, aDst: Single): Single;
- function tsBlendValueModulate(const aSrc, aDst: Single): Single;
-
- function tsBlendColorAlpha(const aSrc, aDst: TtsColor4f): TtsColor4f;
- function tsBlendColorAdditive(const aSrc, aDst: TtsColor4f): TtsColor4f;
- function tsBlendColorAdditiveAlpha(const aSrc, aDst: TtsColor4f): TtsColor4f;
-
- function tsStrAlloc(aSize: Cardinal): PWideChar;
- function tsStrNew(const aText: PWideChar): PWideChar;
- procedure tsStrDispose(const aText: PWideChar);
- function tsStrLength(aText: PWideChar): Cardinal;
- function tsStrCopy(aDst, aSrc: PWideChar): PWideChar;
-
- function tsAnsiToWide(aDst: PWideChar; const aSize: Integer; aSrc: PAnsiChar; const aCodePage: TtsCodePage; const aDefaultChar: WideChar): Integer;
- function tsISO_8859_1ToWide(aDst: PWideChar; const aSize: Integer; aSrc: PAnsiChar): Integer;
- function tsUTF8ToWide(aDst: PWideChar; const aSize: Integer; const aSrc: PAnsiChar; const aDefaultChar: WideChar): Integer;
- function tsUTFBE16ToWide(aDst: PWideChar; const aDstSize: Integer; aSrc: PByte; aSrcSize: Integer; const aDefaultChar: WideChar): Integer;
- function tsAnsiSBCDToWide(aDst: PWideChar; const aSize: Integer; aSrc: PAnsiChar; const aCodePage: TtsCodePage; const aDefaultChar: WideChar): Integer;
-
- implementation
-
- uses
- math,
- utsConstants;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsRefManager/////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsRefManager.AddSlave(const aSlave: TtsRefManager);
- begin
- if Assigned(fSlaveRefs) then
- fSlaveRefs.Add(aSlave);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TtsRefManager.DelSlave(const aSlave: TtsRefManager): Boolean;
- begin
- result := false;
- if Assigned(fSlaveRefs) then
- result := (fSlaveRefs.Remove(aSlave) >= 0);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsRefManager.Create(const aMaster: TtsRefManager);
- begin
- inherited Create;
- fMasterRef := aMaster;
- fSlaveRefs := TObjectList.Create(false);
- if Assigned(fMasterRef) then
- fMasterRef.AddSlave(self);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TtsRefManager.Destroy;
- var
- m: TtsRefManager;
- begin
- fSlaveRefs.OwnsObjects := true;
- FreeAndNil(fSlaveRefs);
- m := fMasterRef;
- fMasterRef := nil;
- if Assigned(m) then
- m.DelSlave(self);
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsMultiMasterRefManager//////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsMultiMasterRefManager.AddMaster(const aMaster: TtsRefManager);
- begin
- if Assigned(fMasterRefs) then begin
- fMasterRefs.Add(aMaster);
- aMaster.AddSlave(self);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TtsMultiMasterRefManager.DelMaster(const aMaster: TtsRefManager);
- begin
- if Assigned(fMasterRefs) then begin
- if (fMasterRefs.Remove(aMaster) >= 0) then
- aMaster.DelSlave(self);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsMultiMasterRefManager.Create(const aMaster: TtsRefManager);
- begin
- inherited Create(aMaster);
- fMasterRefs := TObjectList.Create(false);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- destructor TtsMultiMasterRefManager.Destroy;
- var
- i: Integer;
- m: TObjectList;
- begin
- m := fMasterRefs;
- try
- fMasterRefs := nil;
- for i := m.Count-1 downto 0 do
- (m[i] as TtsRefManager).DelSlave(self);
- finally
- FreeAndNil(m);
- end;
- inherited Destroy;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //Helper Methods////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsColor4f(r, g, b, a: Single): TtsColor4f;
- begin
- result.r := r;
- result.g := g;
- result.b := b;
- result.a := a;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsPosition(const x, y: Integer): TtsPosition;
- begin
- result.x := x;
- result.y := y;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsRect(const l, t, r, b: Integer): TtsRect;
- begin
- result.Left := l;
- result.Top := t;
- result.Right := r;
- result.Bottom := b;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsRect(const aTopLeft, aBottomRight: TtsPosition): TtsRect;
- begin
- result.TopLeft := aTopLeft;
- result.BottomRight := aBottomRight;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsVector4f(X, Y, Z, W: Single): TtsVector4f;
- begin
- result[0] := X;
- result[1] := Y;
- result[2] := Z;
- result[3] := W;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsMatrix4f(X, Y, Z, P: TtsVector4f): TtsMatrix4f;
- begin
- result[0] := X;
- result[1] := Y;
- result[2] := Z;
- result[3] := P;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsFormatSize(const aFormat: TtsFormat): Integer;
- begin
- case aFormat of
- tsFormatRGBA8: result := 4;
- tsFormatLumAlpha8: result := 2;
- tsFormatAlpha8: result := 1;
- tsFormatLum8: result := 1;
- else
- result := 0;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure tsFormatMap(const aFormat: TtsFormat; var aData: PByte; const aColor: TtsColor4f);
- var
- i: Integer;
- s: Single;
- begin
- case aFormat of
- tsFormatRGBA8: begin
- for i := 0 to 3 do begin
- aData^ := Trunc($FF * min(aColor.arr[i], 1.0));
- inc(aData);
- end;
- end;
-
- tsFormatLumAlpha8: begin
- s := 0.30 * min(aColor.r, 1.0) +
- 0.59 * min(aColor.g, 1.0) +
- 0.11 * min(aColor.b, 1.0);
- aData^ := Trunc($FF * s);
- inc(aData);
- aData^ := Trunc($FF * min(aColor.a, 1.0));
- inc(aData);
- end;
-
- tsFormatAlpha8: begin
- aData^ := Trunc($FF * min(aColor.a, 1.0));
- inc(aData);
- end;
-
- tsFormatLum8: begin
- s := 0.30 * min(aColor.r, 1.0) +
- 0.59 * min(aColor.g, 1.0) +
- 0.11 * min(aColor.b, 1.0);
- aData^ := Trunc($FF * s);
- inc(aData);
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure tsFormatUnmap(const aFormat: TtsFormat; var aData: PByte; out aColor: TtsColor4f);
- var
- i: Integer;
- begin
- case aFormat of
- tsFormatRGBA8: begin
- for i := 0 to 3 do begin
- aColor.arr[i] := aData^ / $FF;
- inc(aData);
- end;
- end;
-
- tsFormatLumAlpha8: begin
- aColor.r := aData^ / $FF;
- aColor.g := aData^ / $FF;
- aColor.b := aData^ / $FF;
- inc(aData);
- aColor.a := aData^ / $FF;
- inc(aData);
- end;
-
- tsFormatAlpha8: begin
- aColor.r := 1.0;
- aColor.g := 1.0;
- aColor.b := 1.0;
- aColor.a := aData^ / $FF;
- inc(aData);
- end;
-
- tsFormatLum8: begin
- aColor.r := aData^ / $FF;
- aColor.g := aData^ / $FF;
- aColor.b := aData^ / $FF;
- aColor.a := 1.0;
- inc(aData);
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsBlendValueIgnore(const aSrc, aDst: Single): Single;
- begin
- result := aDst;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsBlendValueReplace(const aSrc, aDst: Single): Single;
- begin
- result := aSrc;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsBlendValueModulate(const aSrc, aDst: Single): Single;
- begin
- result := aSrc * aDst;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsBlendColorAlpha(const aSrc, aDst: TtsColor4f): TtsColor4f;
- var
- i: Integer;
- begin
- for i := 0 to 2 do
- result.arr[i] := aSrc.arr[i] * aSrc.a + aDst.arr[i] * (1 - aSrc.a);
- result.a := aSrc.a + aDst.a * (1 - aSrc.a);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsBlendColorAdditive(const aSrc, aDst: TtsColor4f): TtsColor4f;
- var
- i: Integer;
- begin
- for i := 0 to 3 do
- result.arr[i] := aSrc.arr[i] + aDst.arr[i];
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsBlendColorAdditiveAlpha(const aSrc, aDst: TtsColor4f): TtsColor4f;
- var
- i: Integer;
- begin
- for i := 0 to 2 do
- result.arr[i] := aSrc.arr[i] * aSrc.a + aDst.arr[i];
- result.a := aDst.a;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsStrAlloc(aSize: Cardinal): PWideChar;
- begin
- aSize := (aSize + 1) shl 1;
- GetMem(result, aSize);
- FillChar(result^, aSize, 0);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsStrNew(const aText: PWideChar): PWideChar;
- begin
- result := tsStrAlloc(tsStrLength(aText));
- tsStrCopy(result, aText);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure tsStrDispose(const aText: PWideChar);
- begin
- FreeMem(aText);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsStrLength(aText: PWideChar): Cardinal;
- begin
- result := 0;
- if Assigned(aText) then
- while (ord(aText^) <> 0) do begin
- inc(result);
- inc(aText);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsStrCopy(aDst, aSrc: PWideChar): PWideChar;
- begin
- result := aDst;
- if Assigned(aDst) and Assigned(aSrc) then
- while ord(aSrc^) <> 0 do begin
- aDst^ := aSrc^;
- inc(aDst);
- inc(aSrc);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsAnsiToWide(aDst: PWideChar; const aSize: Integer; aSrc: PAnsiChar;
- const aCodePage: TtsCodePage; const aDefaultChar: WideChar): Integer;
- begin
- case aCodePage of
- tsUTF8:
- result := tsUTF8ToWide(aDst, aSize, aSrc, aDefaultChar);
-
- tsISO_8859_1:
- result := tsISO_8859_1ToWide(aDst, aSize, aSrc);
- else
- result := tsAnsiSBCDToWide(aDst, aSize, aSrc, aCodePage, aDefaultChar);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsISO_8859_1ToWide(aDst: PWideChar; const aSize: Integer; aSrc: PAnsiChar): Integer;
- begin
- result := 0;
- if Assigned(aDst) and Assigned(aSrc) then
- while (ord(aSrc^) <> 0) and (result < aSize) do begin
- aDst^ := WideChar(aSrc^);
- inc(aDst);
- inc(aSrc);
- inc(result);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsUTF8ToWide(aDst: PWideChar; const aSize: Integer; const aSrc: PAnsiChar; const aDefaultChar: WideChar): Integer;
-
- procedure AddToDest(aCharCode: UInt64);
- begin
- if (aCharCode > $FFFF) then
- aCharCode := ord(aDefaultChar);
-
- PWord(aDst)^ := aCharCode;
- inc(aDst);
- result := result + 1;
- end;
-
- const
- STATE_STARTBYTE = 0;
- STATE_FOLLOWBYTE = 1;
- var
- cc: UInt64;
- len, state, c: Integer;
- p: PByte;
- tmp: Byte;
- begin
- result := 0;
- if not Assigned(aDst) or not Assigned(aSrc) or (aSize <= 0) then
- exit;
-
- c := 0;
- cc := 0;
- p := PByte(aSrc);
- len := Length(aSrc);
- state := STATE_STARTBYTE;
- while (len > 0) do begin
- case state of
- STATE_STARTBYTE: begin
- if (p^ and $80 = 0) then begin
- AddToDest(p^);
- end else if (p^ and $40 > 0) then begin
- tmp := p^;
- c := 0;
- while (tmp and $80) > 0 do begin
- inc(c);
- tmp := tmp shl 1;
- end;
- cc := p^ and ((1 shl (7 - c)) - 1);
- state := STATE_FOLLOWBYTE;
- c := c - 1;
- end;
- end;
-
- STATE_FOLLOWBYTE: begin
- if ((p^ and $C0) = $80) then begin
- cc := (cc shl 6) or (p^ and $3F);
- c := c - 1;
- if (c = 0) then begin
- AddToDest(cc);
- state := STATE_STARTBYTE;
- end;
- end else
- state := STATE_STARTBYTE;
- end;
- end;
-
- if (result >= aSize) then
- exit;
- inc(p);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsUTFBE16ToWide(aDst: PWideChar; const aDstSize: Integer; aSrc: PByte; aSrcSize: Integer;
- const aDefaultChar: WideChar): Integer;
- var
- tmp: Word;
-
- procedure AddToDest(aCharCode: Word);
- begin
- if ((aCharCode and $D800) = $D800) or
- ((aCharCode and $DC00) = $DC00) then
- aCharCode := Ord(aDefaultChar);
-
- aDst^ := WideChar(aCharCode);
- inc(aDst, 1);
- result := result + 1;
- end;
-
- begin
- result := 0;
- while (aSrcSize > 1) and (aDstSize > 0) do begin
- {$IFDEF FPC}
- tmp := (aSrc^ shl 8) or (aSrc + 1)^;
- {$ELSE}
- tmp := (PByteArray(aSrc)[0] shl 8) or PByteArray(aSrc)[1];
- {$ENDIF}
- inc(aSrc, 2);
- dec(aSrcSize, 2);
- AddToDest(tmp);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function tsAnsiSBCDToWide(aDst: PWideChar; const aSize: Integer; aSrc: PAnsiChar;
- const aCodePage: TtsCodePage; const aDefaultChar: WideChar): Integer;
- var
- tmp: WideChar;
- cp: PtsCodePageValues;
- begin
- result := 0;
- cp := TS_CODE_PAGE_LUT[aCodePage];
- if not Assigned(aDst) or
- not Assigned(aSrc) or
- not Assigned(cp) or
- (aSize < 0) then exit;
-
- while (Ord(aSrc^) <> 0) and (result < aSize) do begin
- tmp := WideChar(cp^[aSrc^]);
- if (ord(tmp) = 0) then begin
- if (ord(aDefaultChar) <> 0) then begin
- aDst^ := aDefaultChar;
- inc(aDst);
- end;
- end else begin
- aDst^ := tmp;
- inc(aDst);
- end;
- inc(aSrc);
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsKernel1D///////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsKernel1D.Create(const aRadius, aStrength: Single);
- var
- TempRadius, SQRRadius, TempStrength, TempValue: Double;
- Idx: Integer;
-
- function CalcValue(const aIndex: Integer): Single;
- var
- Temp: Double;
- begin
- Temp := Max(0, Abs(aIndex) - TempStrength);
- Temp := Sqr(Temp * TempRadius) / SQRRadius;
- result := Exp(-Temp);
- end;
-
- begin
- inherited Create;
-
- // calculate new radius and strength
- TempStrength := Min(aRadius - 1, aRadius * aStrength);
- TempRadius := aRadius - TempStrength;
- SQRRadius := sqr(TempRadius) * sqr(TempRadius);
-
- // caluculating size of the kernel
- Size := Round(TempRadius);
- while CalcValue(Size) > 0.001 do
- Inc(Size);
- Size := Size -1;
- ItemCount := Size * 2 +1;
- SetLength(Items, ItemCount);
-
- // calculate Value (yes thats right. there is no -1)
- for Idx := 0 to Size do begin
- TempValue := CalcValue(Idx);
-
- with Items[Size + Idx] do begin
- Offset := Idx;
- Value := TempValue;
- end;
-
- with Items[Size - Idx] do begin
- Offset := -Idx;
- Value := TempValue;
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TtsKernel2D///////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- constructor TtsKernel2D.Create(const aRadius, aStrength: Single);
- var
- tmpStrenght: Double;
- tmpRadius: Double;
- tmpValue: Double;
- sqrRadius: Double;
- x, y, w, h: Integer;
-
- function CalcValue(const aIndex: Double): Double;
- begin
- result := max(0, Abs(aIndex) - tmpStrenght);
- result := Sqr(result * tmpRadius) / sqrRadius;
- result := Exp(-result);
- end;
-
- procedure CalcSize(var aSize, aMidSize: Integer);
- begin
- aSize := 0;
- aMidSize := 0;
- while CalcValue(aSize) > 0.5 do begin
- inc(aSize, 1);
- inc(aMidSize, 1);
- end;
- while CalcValue(aSize) > 0.001 do
- Inc(aSize, 1);
- end;
-
- procedure SetItem(const x, y: Integer);
- begin
- with Items[(SizeY + y) * w + (SizeX + x)] do begin
- OffsetX := x;
- OffsetY := y;
- Value := tmpValue;
- end;
- end;
-
- procedure QuickSort(l, r: Integer);
- var
- _l, _r: Integer;
- p, t: TtsKernel2DItem;
- begin
- repeat
- _l := l;
- _r := r;
- p := Items[(l + r) shr 1];
-
- repeat
- while (Items[_l].Value > p.Value) do
- inc(_l, 1);
-
- while (Items[_r].Value < p.Value) do
- dec(_r, 1);
-
- if (_l <= _r) then begin
- t := Items[_l];
- Items[_l] := Items[_r];
- Items[_r] := t;
- inc(_l, 1);
- dec(_r, 1);
- end;
- until (_l > _r);
-
- if (l < _r) then
- QuickSort(l, _r);
-
- l := _l;
- until (_l >= r);
- end;
-
- begin
- inherited Create;
-
- tmpStrenght := Min(aRadius - 1.0, aRadius * aStrength);
- tmpRadius := aRadius - tmpStrenght;
- sqrRadius := sqr(tmpRadius) * sqr(tmpRadius);
-
- CalcSize(SizeX, MidSizeX);
- CalcSize(SizeY, MidSizeY);
-
- ValueSum := 0.0;
- w := 2 * SizeX + 1;
- h := 2 * SizeY + 1;
- ItemCount := w * h;
- SetLength(Items, ItemCount);
-
- for y := 0 to SizeY do begin
- for x := 0 to SizeX do begin
- tmpValue := CalcValue(sqrt(Sqr(x) + Sqr(y)));
-
- SetItem( x, y);
- SetItem( x, -y);
- SetItem(-x, -y);
- SetItem(-x, y);
-
- ValueSum := ValueSum + tmpValue;
- if (x > 0) and (y > 0) then
- ValueSum := ValueSum + tmpValue;
- end;
- end;
-
- QuickSort(0, ItemCount-1);
-
- while (Items[ItemCount-1].Value < 0.001) do
- dec(ItemCount, 1);
- SetLength(Items, ItemCount);
- end;
-
- end.
-
|