BGRA Grid Texture Demo

[Gigatron]

Hi,

If we look this topic an interesting effect made easily here;
https://forum.lazarus.freepascal.org/index.php/topic,66963.msg514647.html#msg514647

Draw 208 x 208 cells and copy 4x4 pixel of bitmap on each cells;
Image source from amiga copper cunky example :

Documented code under 100 lines !

Code: Pascal  [Select][+][-]

1. unit Unit1;
2.  
3. {$mode objfpc}{$H+}
4.  
5. interface
6.  
7. uses
8.   Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls,
9.   BGRAVirtualScreen, BGRABitmap, BGRABitmapTypes;
10.  
11. type
12.   { TForm1 }
13.   TForm1 = class(TForm)
14.     BGRAVirtualScreen1: TBGRAVirtualScreen;
15.     btnStart: TButton;
16.     Timer1: TTimer;
17.     procedure BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
18.     procedure FormCreate(Sender: TObject);
19.     procedure FormDestroy(Sender: TObject);
20.     procedure Timer1Timer(Sender: TObject);
21.   private
22.     tt: Single;
23.   public
24.   end;
25.  
26. var
27.   Form1: TForm1;
28.   tex: TBGRABitmap;
29.  
30. implementation
31.  
32. {$R *.lfm}
33.  
34. { TForm1 }
35.  
36. procedure TForm1.FormCreate(Sender: TObject);
37. begin
38.   try
39.     tex := TBGRABitmap.Create('image2.png'); // 208*208
40.   except
41.     on E: Exception do
42.       ShowMessage('Erreur de chargement de la texture : ' + E.Message);
43.   end;
44. end;
45.  
46. procedure TForm1.BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
47. const
48.   CellW = 4;   // 4 x 4 cells
49.   CellH = 4;
50.   SpaceX = CellW +4;
51.   SpaceY = CellH +4;
52.   Effet_Amp = 16;
53. var
54.   x, y: integer;
55.   x0, y0: single;
56.   SourceRect: TRect;
57. begin
58.  
59.   if tex = nil then exit;
60.   Bitmap.Fill(BGRA(0,0,0));
61.  
62.   for x := 0 to 50 do     //51 x CellW 4 = 204 pixel H
63.     for y := 0 to 50 do  // 51 x CellH 4 = 204 pixel W
64.     begin
65.       // fx sinus cos
66.       x0 := x * SpaceX + Effet_Amp * Cos(4 * tt + 0.3 * y) + 100; // 100 X offset of Texture
67.       y0 := y * SpaceY + (x / 6 + 2) * Sin(3 * tt + 0.2 * x) + 50; // 50 Yoffset of Texture
68.  
69.       SourceRect := Rect(                      // get 4*4 pixel from texture
70.         (x * CellW) mod tex.Width ,            // get 4*4 pixel from texture
71.         (y * CellH) mod tex.Height ,           // get 4*4 pixel from texture
72.         ((x * CellW) + CellW) mod tex.Width,   // get 4*4 pixel from texture
73.         ((y * CellH) + CellH) mod tex.Height   // get 4*4 pixel from texture
74.       );
75.       Bitmap.PutImagePart(Round(x0), Round(y0),tex, SourceRect, dmSet); // paste 4x4 pixel to each cells
76.       // PutImagePart is working like blitter on Amiga copy A + B to C destination
77.     end;
78. end;
79.  
80. procedure TForm1.Timer1Timer(Sender: TObject);
81. begin
82.   tt := tt + 0.025;  // animate timer
83.   BGRAVirtualScreen1.DiscardBitmap;
84. end;
85.  
86. procedure TForm1.FormDestroy(Sender: TObject);
87. begin
88.   tex.Free;
89. end;
90. end.

[Guva]

@Gigatron nice !!!
I couldn't resist rewriting it with a little something extra.

Code: Pascal  [Select][+][-]

1. program DVDScreensaver;
2. {$WARN 5027 off : Local variable "$1" is assigned but never used}
3. uses
4.   raylib, math;
5.  
6. const
7.   ScreenWidth = 800;
8.   ScreenHeight = 600;
9.   CellW = 4;
10.   CellH = 4;
11.   SpaceX = CellW + 4;
12.   SpaceY = CellH + 4;
13.   Effet_Amp = 4;
14.  
15. var
16.   tt: Single = 0;
17.   tex: TTexture2D;
18.   running: Boolean = True;
19.   gridWidth, gridHeight: Integer;
20.   posX, posY: Single;
21.   speedX, speedY: Single;
22.   currentColor: TColor;
23.   rotation: Single;
24.   logoSize: Single;
25.  
26. procedure LoadResources;
27. begin
28.  
29.   if FileExists('image2.png') then
30.   begin
31.     tex := LoadTexture('image2.png');
32.  
33.     gridWidth := tex.width div CellW;
34.     gridHeight := tex.height div CellH;
35.  
36.     posX := 0;//ScreenWidth / 2;
37.     posY := 0;//ScreenHeight / 2;
38.     speedX := 120;
39.     speedY := 120;
40.     currentColor := WHITE;
41.     rotation := 0;
42.     logoSize := 1.0;
43.   end
44.   else
45.   begin
46.     TraceLog(LOG_WARNING, 'Texture file image2.png not found');
47.     running := False;
48.   end;
49. end;
50.  
51. procedure UnloadResources;
52. begin
53.   UnloadTexture(tex);
54. end;
55.  
56. function GetRandomColor: TColor;
57. begin
58.   case GetRandomValue(0, 6) of
59.     0: Result := RED;
60.     1: Result := GREEN;
61.     2: Result := BLUE;
62.     3: Result := YELLOW;
63.     4: Result := PURPLE;
64.     5: Result := ORANGE;
65.     else Result := SKYBLUE;
66.   end;
67. end;
68.  
69. procedure UpdateDVDLogo(dt: Single);
70. begin
71.  
72.   posX := posX + speedX * dt;
73.   posY := posY + speedY * dt;
74.  
75.   if (posX < 0) or (posX > ScreenWidth - gridWidth * SpaceX) then
76.   begin
77.     speedX := -speedX;
78.     currentColor := GetRandomColor;
79.   end;
80.  
81.   if (posY < 0) or (posY > ScreenHeight - gridHeight * SpaceY) then
82.   begin
83.     speedY := -speedY;
84.     currentColor := GetRandomColor;
85.   end;
86.  
87.   rotation := rotation + 20 * dt;
88.   if rotation > 360 then rotation := rotation - 360;
89.  
90.   logoSize := 0.9 + 0.1 * Sin(tt * 2);
91. end;
92.  
93. procedure DrawDVDLogo;
94. var
95.   x, y: Integer;
96.   x0, y0: Single;
97.   SourceRect, DestRect: TRectangle;
98.   origin: TVector2;
99. begin
100.   origin.x := (gridWidth * SpaceX) / 2;
101.   origin.y := (gridHeight * SpaceY) / 2;
102.  
103.   for x := 0 to gridWidth - 1 do
104.     for y := 0 to gridHeight - 1 do
105.     begin
106.  
107.       x0 := posX + x * SpaceX + Effet_Amp * Cos(4 * tt + 0.3 * y);
108.       y0 := posY + y * SpaceY + (x / 6 + 2) * Sin(3 * tt + 0.2 * x);
109.  
110.       SourceRect := RectangleCreate(
111.         (x * CellW) mod tex.width,
112.         (y * CellH) mod tex.height,
113.         CellW,
114.         CellH
115.       );
116.  
117.       DestRect := RectangleCreate(
118.         x0,
119.         y0,
120.         CellW * logoSize,
121.         CellH * logoSize
122.       );
123.  
124.       DrawTexturePro(
125.         tex,
126.         SourceRect,
127.         DestRect,
128.         Vector2Create(CellW/2 * logoSize, CellH/2 * logoSize),
129.         rotation,
130.         currentColor
131.       );
132.     end;
133. end;
134.  
135. procedure UpdateAndDraw;
136. var
137.   dt: Single;
138. begin
139.   dt := GetFrameTime();
140.  
141.  
142.   tt += 0.025;
143.  
144.   UpdateDVDLogo(dt);
145.  
146.   ClearBackground(DARKGRAY);
147.  
148.   DrawDVDLogo;
149.  
150.   DrawText(TextFormat('Position: %.1f, %.1f', posX, posY), 10, 10, 20, LIGHTGRAY);
151.   DrawText(TextFormat('Speed: %.1f, %.1f', speedX, speedY), 10, 30, 20, LIGHTGRAY);
152. end;
153.  
154. begin
155.   InitWindow(ScreenWidth, ScreenHeight, 'DVD Logo Animation');
156.   SetTargetFPS(60);
157.   SetRandomSeed(Trunc(GetTime()*1000));
158.   LoadResources;
159.  
160.   while running and not WindowShouldClose do
161.   begin
162.     BeginDrawing;
163.       UpdateAndDraw;
164.     EndDrawing;
165.   end;
166.  
167.   UnloadResources;
168.   CloseWindow;
169. end.                                
170.  

[Gigatron]

@Guva
Nice it working perfectly, thank you.
Here Ripple Fx code nothing changed on the code just DrawDVDLogo section;

Code: Pascal  [Select][+][-]

1. procedure DrawDVDLogo;
2. var
3.   x, y: Integer;
4.   x0, y0: Single;
5.   SourceRect, DestRect: TRectangle;
6.   centerX, centerY, distance, phase, amplitude: Single;
7.   dx, dy: Single;
8. begin
9.   centerX := (gridWidth * SpaceX) / 2;
10.   centerY := (gridHeight * SpaceY) / 2;
11.  
12.   for x := 0 to gridWidth - 1 do
13.     for y := 0 to gridHeight - 1 do
14.     begin
15.  
16.       dx := x * SpaceX - centerX;
17.       dy := y * SpaceY - centerY;
18.       distance := sqrt(dx * dx + dy * dy);
19.       phase := distance / 15.0 - tt * 2;
20.       amplitude := Effet_Amp * sin(phase);
21.  
22.       if distance > 0 then
23.         amplitude := amplitude * exp(-distance / 180.0)
24.       else
25.         amplitude := 0;
26.  
27.       if distance > 0 then
28.       begin
29.         dx := dx / distance;
30.         dy := dy / distance;
31.         x0 := posX + x * SpaceX + dx * amplitude;
32.         y0 := posY + y * SpaceY + dy * amplitude;
33.       end
34.       else
35.       begin
36.         x0 := posX + x * SpaceX;
37.         y0 := posY + y * SpaceY;
38.       end;
39.  
40.       SourceRect := RectangleCreate(
41.         (x * CellW) mod tex.width,
42.         (y * CellH) mod tex.height,
43.         CellW,
44.         CellH
45.       );
46.  
47.       DestRect := RectangleCreate(
48.         x0,
49.         y0,
50.         CellW * logoSize,
51.         CellH * logoSize
52.       );
53.  
54.       DrawTexturePro(
55.         tex,
56.         SourceRect,
57.         DestRect,
58.         Vector2Create(CellW/2 * logoSize, CellH/2 * logoSize),
59.         0,
60.         currentColor
61.       );
62.     end;
63. end;