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.

467 lines
14 KiB

  1. unit utsImage;
  2. {$IFDEF FPC}
  3. {$mode objfpc}{$H+}
  4. {$ENDIF}
  5. interface
  6. uses
  7. Classes, SysUtils,
  8. utsTypes, utsUtils, utsContext;
  9. type
  10. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  11. TtsImage = class;
  12. TtsImageLoadFunc = procedure(const aImage: TtsImage; X, Y: Integer; var aPixel: TtsColor4f; aArgs: Pointer);
  13. TtsImageBlendFunc = function (const aSrc, aDst: TtsColor4f; aArgs: Pointer): TtsColor4f;
  14. TtsImage = class(TtsRefManager)
  15. private
  16. fContext: TtsContext;
  17. fWidth: Integer;
  18. fHeight: Integer;
  19. fDataSize: Integer;
  20. fLineSize: Integer;
  21. fFormat: TtsFormat;
  22. fData: Pointer;
  23. fHasScanlines: Boolean;
  24. fScanlines: array of Pointer;
  25. function GetScanline(const aIndex: Integer): Pointer;
  26. function GetIsEmpty: Boolean;
  27. procedure UpdateScanlines;
  28. procedure SetData(
  29. const aData: Pointer;
  30. const aFormat: TtsFormat = tsFormatEmpty;
  31. const aWidth: Integer = 0;
  32. const aHeight: Integer = 0;
  33. const aLineSize: Integer = 0;
  34. const aDataSize: Integer = 0);
  35. public
  36. property Context: TtsContext read fContext;
  37. property IsEmpty: Boolean read GetIsEmpty;
  38. property Width: Integer read fWidth;
  39. property Height: Integer read fHeight;
  40. property LineSize: Integer read fLineSize;
  41. property DataSize: Integer read fDataSize;
  42. property Format: TtsFormat read fFormat;
  43. property Data: Pointer read fData;
  44. property Scanline[const aIndex: Integer]: Pointer read GetScanline;
  45. function GetPixelAt(const x, y: Integer; out aColor: TtsColor4f): Boolean;
  46. procedure Assign(const aImage: TtsImage);
  47. procedure CreateEmpty(const aFormat: TtsFormat; const aWidth, aHeight: Integer);
  48. procedure LoadFromFunc(const aFunc: TtsImageLoadFunc; const aArgs: Pointer);
  49. procedure Resize(const aNewWidth, aNewHeight, X, Y: Integer);
  50. procedure FindMinMax(out aRect: TtsRect);
  51. procedure FillColor(const aColor: TtsColor4f; const aChannelMask: TtsColorChannels; const aModes: TtsImageModes);
  52. procedure FillPattern(const aPattern: TtsImage; X, Y: Integer; const aChannelMask: TtsColorChannels; const aModes: TtsImageModes);
  53. procedure Blend(const aImage: TtsImage; const X, Y: Integer; const aFunc: TtsBlendColorFunc);
  54. procedure Blend(const aImage: TtsImage; const X, Y: Integer; const aFunc: TtsImageBlendFunc; const aArgs: Pointer);
  55. procedure Blur(const aHorzKernel, aVertKernel: TtsKernel1D; const aChannelMask: TtsColorChannels);
  56. constructor Create(const aContext: TtsContext);
  57. destructor Destroy; override;
  58. end;
  59. implementation
  60. uses
  61. Math,
  62. utsConstants;
  63. type
  64. PBlendProxyArgs = ^TBlendProxyArgs;
  65. TBlendProxyArgs = packed record
  66. callback: TtsBlendColorFunc;
  67. end;
  68. function tsImageBlendCallbackProxy(const aSrc, aDst: TtsColor4f; aArgs: Pointer): TtsColor4f;
  69. var
  70. p: PBlendProxyArgs;
  71. begin
  72. p := PBlendProxyArgs(aArgs);
  73. result := p^.callback(aSrc, aDst);
  74. end;
  75. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  76. //TtsImage//////////////////////////////////////////////////////////////////////////////////////////////////////////////
  77. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  78. function TtsImage.GetScanline(const aIndex: Integer): Pointer;
  79. begin
  80. if not fHasScanlines then
  81. UpdateScanlines;
  82. if fHasScanlines and (aIndex >= 0) and (aIndex <= High(fScanlines)) then
  83. result := fScanlines[aIndex]
  84. else
  85. result := nil;
  86. end;
  87. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  88. function TtsImage.GetIsEmpty: Boolean;
  89. begin
  90. result := not Assigned(fData);
  91. end;
  92. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  93. procedure TtsImage.UpdateScanlines;
  94. var
  95. i: Integer;
  96. tmp: PByte;
  97. begin
  98. SetLength(fScanlines, fHeight);
  99. for i := 0 to fHeight-1 do begin
  100. tmp := fData;
  101. inc(tmp, i * fLineSize);
  102. fScanlines[i] := tmp;
  103. end;
  104. fHasScanlines := true;
  105. end;
  106. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  107. procedure TtsImage.SetData(const aData: Pointer; const aFormat: TtsFormat;
  108. const aWidth: Integer; const aHeight: Integer;
  109. const aLineSize: Integer; const aDataSize: Integer);
  110. begin
  111. fHasScanlines := false;
  112. if Assigned(fData) then
  113. FreeMemory(fData);
  114. fData := aData;
  115. if Assigned(fData) then begin
  116. fWidth := aWidth;
  117. fHeight := aHeight;
  118. fFormat := aFormat;
  119. fLineSize := aLineSize;
  120. fDataSize := aDataSize;
  121. end else begin
  122. fWidth := 0;
  123. fHeight := 0;
  124. fLineSize := 0;
  125. fDataSize := 0;
  126. fFormat := tsFormatEmpty;
  127. end;
  128. end;
  129. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  130. function TtsImage.GetPixelAt(const x, y: Integer; out aColor: TtsColor4f): Boolean;
  131. var
  132. p: PByte;
  133. begin
  134. result := (x >= 0) and (x < Width) and (y >= 0) and (y < Height);
  135. if result then begin
  136. p := Scanline[y];
  137. inc(p, x * tsFormatSize(Format));
  138. tsFormatUnmap(Format, p, aColor);
  139. end;
  140. end;
  141. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  142. procedure TtsImage.Assign(const aImage: TtsImage);
  143. var
  144. ImgData: Pointer;
  145. begin
  146. GetMem(ImgData, aImage.DataSize);
  147. if Assigned(ImgData) then
  148. Move(aImage.Data^, ImgData^, aImage.DataSize);
  149. SetData(ImgData, aImage.Format, aImage.Width, aImage.Height, aImage.LineSize, aImage.DataSize);
  150. end;
  151. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  152. procedure TtsImage.CreateEmpty(const aFormat: TtsFormat; const aWidth, aHeight: Integer);
  153. var
  154. ImgData: PByte;
  155. lSize, dSize: Integer;
  156. begin
  157. lSize := aWidth * tsFormatSize(aFormat);
  158. lSize := lSize + ((4 - (lSize mod 4)) mod 4);
  159. dSize := aHeight * lSize;
  160. ImgData := AllocMem(dSize);
  161. FillChar(ImgData^, dSize, #0);
  162. SetData(ImgData, aFormat, aWidth, aHeight, lSize, dSize);
  163. end;
  164. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  165. procedure TtsImage.LoadFromFunc(const aFunc: TtsImageLoadFunc; const aArgs: Pointer);
  166. var
  167. X, Y: Integer;
  168. c: TtsColor4f;
  169. p, tmp: PByte;
  170. begin
  171. for Y := 0 to Height - 1 do begin
  172. p := ScanLine[Y];
  173. for X := 0 to Width - 1 do begin
  174. tmp := p;
  175. tsFormatUnmap(fFormat, tmp, c);
  176. aFunc(Self, X, Y, c, aArgs);
  177. tsFormatMap(fFormat, p, c);
  178. end;
  179. end;
  180. end;
  181. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  182. procedure TtsImage.Resize(const aNewWidth, aNewHeight, X, Y: Integer);
  183. var
  184. ImgData: PByte;
  185. pSize, lSize, dSize: Integer;
  186. src, dst: PByte;
  187. YStart, YEnd, YPos, XStart, XEnd: Integer;
  188. begin
  189. if (aNewHeight = 0) or (aNewWidth = 0) then begin
  190. SetData(nil);
  191. exit;
  192. end;
  193. pSize := tsFormatSize(Format);
  194. lSize := pSize * aNewWidth;
  195. lSize := lSize + ((4 - (lSize mod 4)) mod 4);
  196. dSize := lSize * aNewHeight;
  197. GetMem(ImgData, dSize);
  198. try
  199. FillChar(ImgData^, dSize, 0);
  200. // positions
  201. YStart := Max(0, Y);
  202. YEnd := Min(aNewHeight, Y + Height);
  203. XStart := Max(0, X);
  204. XEnd := Min(aNewWidth, X + Width);
  205. // copy data
  206. for YPos := YStart to YEnd -1 do begin
  207. dst := ImgData;
  208. Inc(dst, lSize * YPos + pSize * XStart);
  209. src := fData;
  210. Inc(src, fLineSize * (YPos - Y) + pSize * (XStart - X));
  211. Move(src^, dst^, (XEnd - XStart) * pSize);
  212. end;
  213. // assign
  214. SetData(ImgData, Format, aNewWidth, aNewHeight, lSize, dSize);
  215. except
  216. FreeMem(ImgData);
  217. end;
  218. end;
  219. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  220. procedure TtsImage.FindMinMax(out aRect: TtsRect);
  221. var
  222. X, Y: Integer;
  223. c: TtsColor4f;
  224. p: PByte;
  225. begin
  226. aRect.Top := -1;
  227. aRect.Left := -1;
  228. aRect.Right := -1;
  229. aRect.Bottom := -1;
  230. // Search for MinMax
  231. for Y := 0 to Height-1 do begin
  232. p := ScanLine[Y];
  233. for X := 0 to Width-1 do begin
  234. tsFormatUnmap(Format, p, c);
  235. if c.a > 0 then begin
  236. if (X < aRect.Left) or (aRect.Left = -1) then
  237. aRect.Left := X;
  238. if (X+1 > aRect.Right) or (aRect.Right = -1) then
  239. aRect.Right := X+1;
  240. if (Y < aRect.Top) or (aRect.Top = -1) then
  241. aRect.Top := Y;
  242. if (Y+1 > aRect.Bottom) or (aRect.Bottom = -1) then
  243. aRect.Bottom := Y+1;
  244. end;
  245. end;
  246. end;
  247. end;
  248. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  249. procedure TtsImage.FillColor(const aColor: TtsColor4f; const aChannelMask: TtsColorChannels;
  250. const aModes: TtsImageModes);
  251. var
  252. x, y: Integer;
  253. rp, wp: PByte;
  254. c: TtsColor4f;
  255. ch: TtsColorChannel;
  256. i: Integer;
  257. begin
  258. for y := 0 to Height-1 do begin
  259. rp := Scanline[y];
  260. wp := rp;
  261. for x := 0 to Width-1 do begin
  262. tsFormatUnmap(Format, rp, c);
  263. for i := 0 to 3 do begin
  264. ch := TtsColorChannel(i);
  265. if (ch in aChannelMask) then
  266. c.arr[i] := TS_IMAGE_MODE_FUNCTIONS[aModes[ch]](aColor.arr[i], c.arr[i]);
  267. end;
  268. tsFormatMap(Format, wp, c);
  269. end;
  270. end;
  271. end;
  272. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  273. procedure TtsImage.FillPattern(const aPattern: TtsImage; X, Y: Integer;
  274. const aChannelMask: TtsColorChannels; const aModes: TtsImageModes);
  275. var
  276. _x, _y, posX, i: Integer;
  277. src, dst, tmp: PByte;
  278. cSrc, cDst: TtsColor4f;
  279. ch: TtsColorChannel;
  280. begin
  281. if x < 0 then
  282. x := Random(aPattern.Width);
  283. if y < 0 then
  284. y := Random(aPattern.Height);
  285. for _y := 0 to Height-1 do begin
  286. src := aPattern.Scanline[(y + _y) mod aPattern.Height];
  287. dst := Scanline[_y];
  288. inc(src, x);
  289. posX := x;
  290. for _x := 0 to Width-1 do begin
  291. if (posX >= aPattern.Width) then begin
  292. src := aPattern.Scanline[(y + _y) mod aPattern.Height];
  293. posX := 0;
  294. end;
  295. tmp := dst;
  296. tsFormatUnmap(aPattern.Format, src, cSrc);
  297. tsFormatUnmap(Format, tmp, cDst);
  298. for i := 0 to 3 do begin
  299. ch := TtsColorChannel(i);
  300. if (ch in aChannelMask) then
  301. cDst.arr[i] := TS_IMAGE_MODE_FUNCTIONS[aModes[ch]](cSrc.arr[i], cDst.arr[i]);
  302. end;
  303. tsFormatMap(Format, dst, cDst);
  304. inc(posX);
  305. end;
  306. end;
  307. end;
  308. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  309. procedure TtsImage.Blend(const aImage: TtsImage; const X, Y: Integer; const aFunc: TtsBlendColorFunc);
  310. var
  311. args: TBlendProxyArgs;
  312. begin
  313. args.callback := aFunc;
  314. Blend(aImage, X, Y, @tsImageBlendCallbackProxy, @args);
  315. end;
  316. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  317. procedure TtsImage.Blend(const aImage: TtsImage; const X, Y: Integer; const aFunc: TtsImageBlendFunc; const aArgs: Pointer);
  318. var
  319. _x, _y, x1, x2, y1, y2: Integer;
  320. src, dst, tmp: PByte;
  321. srcColor, dstColor: TtsColor4f;
  322. srcPixelSize, dstPixelSize: Integer;
  323. begin
  324. x1 := Max(X, 0);
  325. x2 := Min(X + aImage.Width , Width);
  326. y1 := Max(Y, 0);
  327. y2 := Min(Y + aImage.Height, Height);
  328. srcPixelSize := tsFormatSize(aImage.Format);
  329. dstPixelSize := tsFormatSize(Format);
  330. for _y := y1 to y2-1 do begin
  331. src := aImage.Scanline[_y - min(y1, y)];
  332. dst := Scanline[_y];
  333. inc(src, (x1 - x) * srcPixelSize);
  334. inc(dst, x1 * dstPixelSize);
  335. tmp := dst;
  336. for _x := x1 to x2-1 do begin
  337. tsFormatUnmap(aImage.Format, src, srcColor);
  338. tsFormatUnmap( Format, dst, dstColor);
  339. tsFormatMap(aImage.Format, tmp, aFunc(srcColor, dstColor, aArgs));
  340. end;
  341. end;
  342. end;
  343. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  344. procedure TtsImage.Blur(const aHorzKernel, aVertKernel: TtsKernel1D; const aChannelMask: TtsColorChannels);
  345. var
  346. tmpImage: TtsImage;
  347. procedure DoBlur(const aSrc, aDst: TtsImage; const aKernel: TtsKernel1D; const ShiftX, ShiftY: Integer);
  348. var
  349. x, y, i, j: Integer;
  350. src, dst: PByte;
  351. v: Single;
  352. c, tmp: TtsColor4f;
  353. begin
  354. for y := 0 to Height-1 do begin
  355. src := aSrc.Scanline[y];
  356. dst := aDst.Scanline[y];
  357. for x := 0 to Width-1 do begin
  358. // read color and clear channels
  359. v := 0;
  360. tsFormatUnmap(aSrc.Format, src, c);
  361. for i := 0 to 3 do
  362. if (TtsColorChannel(i) in aChannelMask) then
  363. c.arr[i] := 0;
  364. // do blur
  365. for i := 0 to aKernel.ItemCount-1 do with aKernel.Items[i] do begin
  366. if aSrc.GetPixelAt(x + Offset * ShiftX, y + Offset * ShiftY, tmp) then begin
  367. for j := 0 to 3 do begin
  368. if (TtsColorChannel(j) in aChannelMask) then
  369. c.arr[j] := c.arr[j] + tmp.arr[j] * Value;
  370. end;
  371. v := v + Value;
  372. end;
  373. end;
  374. // calc final color and write
  375. for i := 0 to 3 do
  376. if (TtsColorChannel(i) in aChannelMask) then
  377. c.arr[i] := c.arr[i] / v;
  378. tsFormatMap(aDst.Format, dst, c);
  379. end;
  380. end;
  381. end;
  382. begin
  383. tmpImage := TtsImage.Create(fContext);
  384. try
  385. tmpImage.CreateEmpty(Format, Width, Height);
  386. tmpImage.FillColor(tsColor4f(1, 1, 1, 0), TS_COLOR_CHANNELS_RGBA, TS_IMAGE_MODES_REPLACE_ALL);
  387. DoBlur(self, tmpImage, aHorzKernel, 1, 0);
  388. DoBlur(tmpImage, self, aVertKernel, 0, 1);
  389. finally
  390. FreeAndNil(tmpImage);
  391. end;
  392. end;
  393. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  394. constructor TtsImage.Create(const aContext: TtsContext);
  395. begin
  396. inherited Create(aContext);
  397. fContext := aContext;
  398. SetData(nil);
  399. end;
  400. ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  401. destructor TtsImage.Destroy;
  402. begin
  403. SetData(nil);
  404. inherited Destroy;
  405. end;
  406. end.