You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

756 lines
22 KiB

  1. unit utsUtils;
  2. {$IFDEF FPC}
  3. {$mode objfpc}{$H+}
  4. {$ENDIF}
  5. interface
  6. uses
  7. Classes, SysUtils, Contnrs,
  8. utsTypes;
  9. type
  10. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  11. TtsRefManager = class(TObject)
  12. private
  13. fMasterRef: TtsRefManager; // master of this object (master will destroy this object)
  14. fSlaveRefs: TObjectList; // slaves of this object (will destroy all slaves when this objects is destroyed)
  15. protected
  16. procedure AddSlave(const aSlave: TtsRefManager); virtual;
  17. function DelSlave(const aSlave: TtsRefManager): Boolean; virtual;
  18. public
  19. constructor Create(const aMaster: TtsRefManager);
  20. destructor Destroy; override;
  21. end;
  22. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  23. TtsMultiMasterRefManager = class(TtsRefManager)
  24. private
  25. fMasterRefs: TObjectList;
  26. public
  27. procedure AddMaster(const aMaster: TtsRefManager); virtual;
  28. procedure DelMaster(const aMaster: TtsRefManager); virtual;
  29. constructor Create(const aMaster: TtsRefManager);
  30. destructor Destroy; override;
  31. end;
  32. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  33. TtsKernel1DItem = packed record
  34. Offset: Integer;
  35. Value: Single;
  36. end;
  37. TtsKernel1D = class
  38. public
  39. Size: Integer;
  40. Items: array of TtsKernel1DItem;
  41. ItemCount: Integer;
  42. constructor Create(const aRadius, aStrength: Single);
  43. end;
  44. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  45. TtsKernel2DItem = packed record
  46. OffsetX: Integer;
  47. OffsetY: Integer;
  48. Value: Double;
  49. DataOffset: Integer;
  50. end;
  51. TtsKernel2D = class
  52. public
  53. SizeX: Integer;
  54. SizeY: Integer;
  55. MidSizeX: Integer;
  56. MidSizeY: Integer;
  57. ValueSum: Double;
  58. Items: array of TtsKernel2DItem;
  59. ItemCount: Integer;
  60. constructor Create(const aRadius, aStrength: Single);
  61. end;
  62. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  63. EtsException = class(Exception);
  64. EtsRenderer = class(EtsException);
  65. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  66. function tsColor4f(r, g, b, a: Single): TtsColor4f;
  67. function tsPosition(const x, y: Integer): TtsPosition;
  68. function tsRect(const l, t, r, b: Integer): TtsRect; overload;
  69. function tsRect(const aTopLeft, aBottomRight: TtsPosition): TtsRect; overload;
  70. function tsVector4f(X, Y, Z, W: Single): TtsVector4f;
  71. function tsMatrix4f(X, Y, Z, P: TtsVector4f): TtsMatrix4f;
  72. function tsFormatSize(const aFormat: TtsFormat): Integer;
  73. procedure tsFormatMap(const aFormat: TtsFormat; var aData: PByte; const aColor: TtsColor4f);
  74. procedure tsFormatUnmap(const aFormat: TtsFormat; var aData: PByte; out aColor: TtsColor4f);
  75. function tsBlendValueIgnore(const aSrc, aDst: Single): Single;
  76. function tsBlendValueReplace(const aSrc, aDst: Single): Single;
  77. function tsBlendValueModulate(const aSrc, aDst: Single): Single;
  78. function tsBlendColorAlpha(const aSrc, aDst: TtsColor4f): TtsColor4f;
  79. function tsBlendColorAdditive(const aSrc, aDst: TtsColor4f): TtsColor4f;
  80. function tsBlendColorAdditiveAlpha(const aSrc, aDst: TtsColor4f): TtsColor4f;
  81. function tsStrAlloc(aSize: Cardinal): PWideChar;
  82. function tsStrNew(const aText: PWideChar): PWideChar;
  83. procedure tsStrDispose(const aText: PWideChar);
  84. function tsStrLength(aText: PWideChar): Cardinal;
  85. function tsStrCopy(aDst, aSrc: PWideChar): PWideChar;
  86. function tsAnsiToWide(aDst: PWideChar; const aSize: Integer; aSrc: PAnsiChar; const aCodePage: TtsCodePage; const aDefaultChar: WideChar): Integer;
  87. function tsISO_8859_1ToWide(aDst: PWideChar; const aSize: Integer; aSrc: PAnsiChar): Integer;
  88. function tsUTF8ToWide(aDst: PWideChar; const aSize: Integer; const aSrc: PAnsiChar; const aDefaultChar: WideChar): Integer;
  89. function tsUTFBE16ToWide(aDst: PWideChar; const aDstSize: Integer; aSrc: PByte; aSrcSize: Integer; const aDefaultChar: WideChar): Integer;
  90. function tsAnsiSBCDToWide(aDst: PWideChar; const aSize: Integer; aSrc: PAnsiChar; const aCodePage: TtsCodePage; const aDefaultChar: WideChar): Integer;
  91. implementation
  92. uses
  93. math,
  94. utsConstants;
  95. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  96. //TtsRefManager/////////////////////////////////////////////////////////////////////////////////////////////////////////
  97. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  98. procedure TtsRefManager.AddSlave(const aSlave: TtsRefManager);
  99. begin
  100. if Assigned(fSlaveRefs) then
  101. fSlaveRefs.Add(aSlave);
  102. end;
  103. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  104. function TtsRefManager.DelSlave(const aSlave: TtsRefManager): Boolean;
  105. begin
  106. result := false;
  107. if Assigned(fSlaveRefs) then
  108. result := (fSlaveRefs.Remove(aSlave) >= 0);
  109. end;
  110. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  111. constructor TtsRefManager.Create(const aMaster: TtsRefManager);
  112. begin
  113. inherited Create;
  114. fMasterRef := aMaster;
  115. fSlaveRefs := TObjectList.Create(false);
  116. if Assigned(fMasterRef) then
  117. fMasterRef.AddSlave(self);
  118. end;
  119. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  120. destructor TtsRefManager.Destroy;
  121. var
  122. m: TtsRefManager;
  123. begin
  124. fSlaveRefs.OwnsObjects := true;
  125. FreeAndNil(fSlaveRefs);
  126. m := fMasterRef;
  127. fMasterRef := nil;
  128. if Assigned(m) then
  129. m.DelSlave(self);
  130. inherited Destroy;
  131. end;
  132. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  133. //TtsMultiMasterRefManager//////////////////////////////////////////////////////////////////////////////////////////////
  134. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  135. procedure TtsMultiMasterRefManager.AddMaster(const aMaster: TtsRefManager);
  136. begin
  137. if Assigned(fMasterRefs) then begin
  138. fMasterRefs.Add(aMaster);
  139. aMaster.AddSlave(self);
  140. end;
  141. end;
  142. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  143. procedure TtsMultiMasterRefManager.DelMaster(const aMaster: TtsRefManager);
  144. begin
  145. if Assigned(fMasterRefs) then begin
  146. if (fMasterRefs.Remove(aMaster) >= 0) then
  147. aMaster.DelSlave(self);
  148. end;
  149. end;
  150. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  151. constructor TtsMultiMasterRefManager.Create(const aMaster: TtsRefManager);
  152. begin
  153. inherited Create(aMaster);
  154. fMasterRefs := TObjectList.Create(false);
  155. end;
  156. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  157. destructor TtsMultiMasterRefManager.Destroy;
  158. var
  159. i: Integer;
  160. m: TObjectList;
  161. begin
  162. m := fMasterRefs;
  163. try
  164. fMasterRefs := nil;
  165. for i := m.Count-1 downto 0 do
  166. (m[i] as TtsRefManager).DelSlave(self);
  167. finally
  168. FreeAndNil(m);
  169. end;
  170. inherited Destroy;
  171. end;
  172. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  173. //Helper Methods////////////////////////////////////////////////////////////////////////////////////////////////////////
  174. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  175. function tsColor4f(r, g, b, a: Single): TtsColor4f;
  176. begin
  177. result.r := r;
  178. result.g := g;
  179. result.b := b;
  180. result.a := a;
  181. end;
  182. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  183. function tsPosition(const x, y: Integer): TtsPosition;
  184. begin
  185. result.x := x;
  186. result.y := y;
  187. end;
  188. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  189. function tsRect(const l, t, r, b: Integer): TtsRect;
  190. begin
  191. result.Left := l;
  192. result.Top := t;
  193. result.Right := r;
  194. result.Bottom := b;
  195. end;
  196. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  197. function tsRect(const aTopLeft, aBottomRight: TtsPosition): TtsRect;
  198. begin
  199. result.TopLeft := aTopLeft;
  200. result.BottomRight := aBottomRight;
  201. end;
  202. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  203. function tsVector4f(X, Y, Z, W: Single): TtsVector4f;
  204. begin
  205. result[0] := X;
  206. result[1] := Y;
  207. result[2] := Z;
  208. result[3] := W;
  209. end;
  210. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  211. function tsMatrix4f(X, Y, Z, P: TtsVector4f): TtsMatrix4f;
  212. begin
  213. result[0] := X;
  214. result[1] := Y;
  215. result[2] := Z;
  216. result[3] := P;
  217. end;
  218. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  219. function tsFormatSize(const aFormat: TtsFormat): Integer;
  220. begin
  221. case aFormat of
  222. tsFormatRGBA8: result := 4;
  223. tsFormatLumAlpha8: result := 2;
  224. tsFormatAlpha8: result := 1;
  225. tsFormatLum8: result := 1;
  226. else
  227. result := 0;
  228. end;
  229. end;
  230. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  231. procedure tsFormatMap(const aFormat: TtsFormat; var aData: PByte; const aColor: TtsColor4f);
  232. var
  233. i: Integer;
  234. s: Single;
  235. begin
  236. case aFormat of
  237. tsFormatRGBA8: begin
  238. for i := 0 to 3 do begin
  239. aData^ := Trunc($FF * min(aColor.arr[i], 1.0));
  240. inc(aData);
  241. end;
  242. end;
  243. tsFormatLumAlpha8: begin
  244. s := 0.30 * min(aColor.r, 1.0) +
  245. 0.59 * min(aColor.g, 1.0) +
  246. 0.11 * min(aColor.b, 1.0);
  247. aData^ := Trunc($FF * s);
  248. inc(aData);
  249. aData^ := Trunc($FF * min(aColor.a, 1.0));
  250. inc(aData);
  251. end;
  252. tsFormatAlpha8: begin
  253. aData^ := Trunc($FF * min(aColor.a, 1.0));
  254. inc(aData);
  255. end;
  256. tsFormatLum8: begin
  257. s := 0.30 * min(aColor.r, 1.0) +
  258. 0.59 * min(aColor.g, 1.0) +
  259. 0.11 * min(aColor.b, 1.0);
  260. aData^ := Trunc($FF * s);
  261. inc(aData);
  262. end;
  263. end;
  264. end;
  265. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  266. procedure tsFormatUnmap(const aFormat: TtsFormat; var aData: PByte; out aColor: TtsColor4f);
  267. var
  268. i: Integer;
  269. begin
  270. case aFormat of
  271. tsFormatRGBA8: begin
  272. for i := 0 to 3 do begin
  273. aColor.arr[i] := aData^ / $FF;
  274. inc(aData);
  275. end;
  276. end;
  277. tsFormatLumAlpha8: begin
  278. aColor.r := aData^ / $FF;
  279. aColor.g := aData^ / $FF;
  280. aColor.b := aData^ / $FF;
  281. inc(aData);
  282. aColor.a := aData^ / $FF;
  283. inc(aData);
  284. end;
  285. tsFormatAlpha8: begin
  286. aColor.r := 1.0;
  287. aColor.g := 1.0;
  288. aColor.b := 1.0;
  289. aColor.a := aData^ / $FF;
  290. inc(aData);
  291. end;
  292. tsFormatLum8: begin
  293. aColor.r := aData^ / $FF;
  294. aColor.g := aData^ / $FF;
  295. aColor.b := aData^ / $FF;
  296. aColor.a := 1.0;
  297. inc(aData);
  298. end;
  299. end;
  300. end;
  301. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  302. function tsBlendValueIgnore(const aSrc, aDst: Single): Single;
  303. begin
  304. result := aDst;
  305. end;
  306. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  307. function tsBlendValueReplace(const aSrc, aDst: Single): Single;
  308. begin
  309. result := aSrc;
  310. end;
  311. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  312. function tsBlendValueModulate(const aSrc, aDst: Single): Single;
  313. begin
  314. result := aSrc * aDst;
  315. end;
  316. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  317. function tsBlendColorAlpha(const aSrc, aDst: TtsColor4f): TtsColor4f;
  318. var
  319. i: Integer;
  320. begin
  321. for i := 0 to 2 do
  322. result.arr[i] := aSrc.arr[i] * aSrc.a + aDst.arr[i] * (1 - aSrc.a);
  323. result.a := aSrc.a + aDst.a * (1 - aSrc.a);
  324. end;
  325. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  326. function tsBlendColorAdditive(const aSrc, aDst: TtsColor4f): TtsColor4f;
  327. var
  328. i: Integer;
  329. begin
  330. for i := 0 to 3 do
  331. result.arr[i] := aSrc.arr[i] + aDst.arr[i];
  332. end;
  333. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  334. function tsBlendColorAdditiveAlpha(const aSrc, aDst: TtsColor4f): TtsColor4f;
  335. var
  336. i: Integer;
  337. begin
  338. for i := 0 to 2 do
  339. result.arr[i] := aSrc.arr[i] * aSrc.a + aDst.arr[i];
  340. result.a := aDst.a;
  341. end;
  342. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  343. function tsStrAlloc(aSize: Cardinal): PWideChar;
  344. begin
  345. aSize := (aSize + 1) shl 1;
  346. GetMem(result, aSize);
  347. FillChar(result^, aSize, 0);
  348. end;
  349. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  350. function tsStrNew(const aText: PWideChar): PWideChar;
  351. begin
  352. result := tsStrAlloc(tsStrLength(aText));
  353. tsStrCopy(result, aText);
  354. end;
  355. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  356. procedure tsStrDispose(const aText: PWideChar);
  357. begin
  358. FreeMem(aText);
  359. end;
  360. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  361. function tsStrLength(aText: PWideChar): Cardinal;
  362. begin
  363. result := 0;
  364. if Assigned(aText) then
  365. while (ord(aText^) <> 0) do begin
  366. inc(result);
  367. inc(aText);
  368. end;
  369. end;
  370. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  371. function tsStrCopy(aDst, aSrc: PWideChar): PWideChar;
  372. begin
  373. result := aDst;
  374. if Assigned(aDst) and Assigned(aSrc) then
  375. while ord(aSrc^) <> 0 do begin
  376. aDst^ := aSrc^;
  377. inc(aDst);
  378. inc(aSrc);
  379. end;
  380. end;
  381. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  382. function tsAnsiToWide(aDst: PWideChar; const aSize: Integer; aSrc: PAnsiChar;
  383. const aCodePage: TtsCodePage; const aDefaultChar: WideChar): Integer;
  384. begin
  385. case aCodePage of
  386. tsUTF8:
  387. result := tsUTF8ToWide(aDst, aSize, aSrc, aDefaultChar);
  388. tsISO_8859_1:
  389. result := tsISO_8859_1ToWide(aDst, aSize, aSrc);
  390. else
  391. result := tsAnsiSBCDToWide(aDst, aSize, aSrc, aCodePage, aDefaultChar);
  392. end;
  393. end;
  394. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  395. function tsISO_8859_1ToWide(aDst: PWideChar; const aSize: Integer; aSrc: PAnsiChar): Integer;
  396. begin
  397. result := 0;
  398. if Assigned(aDst) and Assigned(aSrc) then
  399. while (ord(aSrc^) <> 0) and (result < aSize) do begin
  400. aDst^ := WideChar(aSrc^);
  401. inc(aDst);
  402. inc(aSrc);
  403. inc(result);
  404. end;
  405. end;
  406. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  407. function tsUTF8ToWide(aDst: PWideChar; const aSize: Integer; const aSrc: PAnsiChar; const aDefaultChar: WideChar): Integer;
  408. procedure AddToDest(aCharCode: UInt64);
  409. begin
  410. if (aCharCode > $FFFF) then
  411. aCharCode := ord(aDefaultChar);
  412. PWord(aDst)^ := aCharCode;
  413. inc(aDst);
  414. result := result + 1;
  415. end;
  416. const
  417. STATE_STARTBYTE = 0;
  418. STATE_FOLLOWBYTE = 1;
  419. var
  420. cc: UInt64;
  421. len, state, c: Integer;
  422. p: PByte;
  423. tmp: Byte;
  424. begin
  425. result := 0;
  426. if not Assigned(aDst) or not Assigned(aSrc) or (aSize <= 0) then
  427. exit;
  428. c := 0;
  429. cc := 0;
  430. p := PByte(aSrc);
  431. len := Length(aSrc);
  432. state := STATE_STARTBYTE;
  433. while (len > 0) do begin
  434. case state of
  435. STATE_STARTBYTE: begin
  436. if (p^ and $80 = 0) then begin
  437. AddToDest(p^);
  438. end else if (p^ and $40 > 0) then begin
  439. tmp := p^;
  440. c := 0;
  441. while (tmp and $80) > 0 do begin
  442. inc(c);
  443. tmp := tmp shl 1;
  444. end;
  445. cc := p^ and ((1 shl (7 - c)) - 1);
  446. state := STATE_FOLLOWBYTE;
  447. c := c - 1;
  448. end;
  449. end;
  450. STATE_FOLLOWBYTE: begin
  451. if ((p^ and $C0) = $80) then begin
  452. cc := (cc shl 6) or (p^ and $3F);
  453. c := c - 1;
  454. if (c = 0) then begin
  455. AddToDest(cc);
  456. state := STATE_STARTBYTE;
  457. end;
  458. end else
  459. state := STATE_STARTBYTE;
  460. end;
  461. end;
  462. if (result >= aSize) then
  463. exit;
  464. inc(p);
  465. end;
  466. end;
  467. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  468. function tsUTFBE16ToWide(aDst: PWideChar; const aDstSize: Integer; aSrc: PByte; aSrcSize: Integer;
  469. const aDefaultChar: WideChar): Integer;
  470. var
  471. tmp: Word;
  472. procedure AddToDest(aCharCode: Word);
  473. begin
  474. if ((aCharCode and $D800) = $D800) or
  475. ((aCharCode and $DC00) = $DC00) then
  476. aCharCode := Ord(aDefaultChar);
  477. aDst^ := WideChar(aCharCode);
  478. inc(aDst, 1);
  479. result := result + 1;
  480. end;
  481. begin
  482. result := 0;
  483. while (aSrcSize > 1) and (aDstSize > 0) do begin
  484. {$IFDEF FPC}
  485. tmp := (aSrc^ shl 8) or (aSrc + 1)^;
  486. {$ELSE}
  487. tmp := (PByteArray(aSrc)[0] shl 8) or PByteArray(aSrc)[1];
  488. {$ENDIF}
  489. inc(aSrc, 2);
  490. dec(aSrcSize, 2);
  491. AddToDest(tmp);
  492. end;
  493. end;
  494. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  495. function tsAnsiSBCDToWide(aDst: PWideChar; const aSize: Integer; aSrc: PAnsiChar;
  496. const aCodePage: TtsCodePage; const aDefaultChar: WideChar): Integer;
  497. var
  498. tmp: WideChar;
  499. cp: PtsCodePageValues;
  500. begin
  501. result := 0;
  502. cp := TS_CODE_PAGE_LUT[aCodePage];
  503. if not Assigned(aDst) or
  504. not Assigned(aSrc) or
  505. not Assigned(cp) or
  506. (aSize < 0) then exit;
  507. while (Ord(aSrc^) <> 0) and (result < aSize) do begin
  508. tmp := WideChar(cp^[aSrc^]);
  509. if (ord(tmp) = 0) then begin
  510. if (ord(aDefaultChar) <> 0) then begin
  511. aDst^ := aDefaultChar;
  512. inc(aDst);
  513. end;
  514. end else begin
  515. aDst^ := tmp;
  516. inc(aDst);
  517. end;
  518. inc(aSrc);
  519. end;
  520. end;
  521. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  522. //TtsKernel1D///////////////////////////////////////////////////////////////////////////////////////////////////////////
  523. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  524. constructor TtsKernel1D.Create(const aRadius, aStrength: Single);
  525. var
  526. TempRadius, SQRRadius, TempStrength, TempValue: Double;
  527. Idx: Integer;
  528. function CalcValue(const aIndex: Integer): Single;
  529. var
  530. Temp: Double;
  531. begin
  532. Temp := Max(0, Abs(aIndex) - TempStrength);
  533. Temp := Sqr(Temp * TempRadius) / SQRRadius;
  534. result := Exp(-Temp);
  535. end;
  536. begin
  537. inherited Create;
  538. // calculate new radius and strength
  539. TempStrength := Min(aRadius - 1, aRadius * aStrength);
  540. TempRadius := aRadius - TempStrength;
  541. SQRRadius := sqr(TempRadius) * sqr(TempRadius);
  542. // caluculating size of the kernel
  543. Size := Round(TempRadius);
  544. while CalcValue(Size) > 0.001 do
  545. Inc(Size);
  546. Size := Size -1;
  547. ItemCount := Size * 2 +1;
  548. SetLength(Items, ItemCount);
  549. // calculate Value (yes thats right. there is no -1)
  550. for Idx := 0 to Size do begin
  551. TempValue := CalcValue(Idx);
  552. with Items[Size + Idx] do begin
  553. Offset := Idx;
  554. Value := TempValue;
  555. end;
  556. with Items[Size - Idx] do begin
  557. Offset := -Idx;
  558. Value := TempValue;
  559. end;
  560. end;
  561. end;
  562. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  563. //TtsKernel2D///////////////////////////////////////////////////////////////////////////////////////////////////////////
  564. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  565. constructor TtsKernel2D.Create(const aRadius, aStrength: Single);
  566. var
  567. tmpStrenght: Double;
  568. tmpRadius: Double;
  569. tmpValue: Double;
  570. sqrRadius: Double;
  571. x, y, w, h: Integer;
  572. function CalcValue(const aIndex: Double): Double;
  573. begin
  574. result := max(0, Abs(aIndex) - tmpStrenght);
  575. result := Sqr(result * tmpRadius) / sqrRadius;
  576. result := Exp(-result);
  577. end;
  578. procedure CalcSize(var aSize, aMidSize: Integer);
  579. begin
  580. aSize := 0;
  581. aMidSize := 0;
  582. while CalcValue(aSize) > 0.5 do begin
  583. inc(aSize, 1);
  584. inc(aMidSize, 1);
  585. end;
  586. while CalcValue(aSize) > 0.001 do
  587. Inc(aSize, 1);
  588. end;
  589. procedure SetItem(const x, y: Integer);
  590. begin
  591. with Items[(SizeY + y) * w + (SizeX + x)] do begin
  592. OffsetX := x;
  593. OffsetY := y;
  594. Value := tmpValue;
  595. end;
  596. end;
  597. procedure QuickSort(l, r: Integer);
  598. var
  599. _l, _r: Integer;
  600. p, t: TtsKernel2DItem;
  601. begin
  602. repeat
  603. _l := l;
  604. _r := r;
  605. p := Items[(l + r) shr 1];
  606. repeat
  607. while (Items[_l].Value > p.Value) do
  608. inc(_l, 1);
  609. while (Items[_r].Value < p.Value) do
  610. dec(_r, 1);
  611. if (_l <= _r) then begin
  612. t := Items[_l];
  613. Items[_l] := Items[_r];
  614. Items[_r] := t;
  615. inc(_l, 1);
  616. dec(_r, 1);
  617. end;
  618. until (_l > _r);
  619. if (l < _r) then
  620. QuickSort(l, _r);
  621. l := _l;
  622. until (_l >= r);
  623. end;
  624. begin
  625. inherited Create;
  626. tmpStrenght := Min(aRadius - 1.0, aRadius * aStrength);
  627. tmpRadius := aRadius - tmpStrenght;
  628. sqrRadius := sqr(tmpRadius) * sqr(tmpRadius);
  629. CalcSize(SizeX, MidSizeX);
  630. CalcSize(SizeY, MidSizeY);
  631. ValueSum := 0.0;
  632. w := 2 * SizeX + 1;
  633. h := 2 * SizeY + 1;
  634. ItemCount := w * h;
  635. SetLength(Items, ItemCount);
  636. for y := 0 to SizeY do begin
  637. for x := 0 to SizeX do begin
  638. tmpValue := CalcValue(sqrt(Sqr(x) + Sqr(y)));
  639. SetItem( x, y);
  640. SetItem( x, -y);
  641. SetItem(-x, -y);
  642. SetItem(-x, y);
  643. ValueSum := ValueSum + tmpValue;
  644. if (x > 0) and (y > 0) then
  645. ValueSum := ValueSum + tmpValue;
  646. end;
  647. end;
  648. QuickSort(0, ItemCount-1);
  649. while (Items[ItemCount-1].Value < 0.001) do
  650. dec(ItemCount, 1);
  651. SetLength(Items, ItemCount);
  652. end;
  653. end.