BGRA Grid Texture Demo
lazarus / 39-Graphics

----------------------------------------------------------------------
Gigatron · 2025-05-10 16:23

Hi,

If we look this topic an interesting effect made easily here;
https://forum.lazarus.freepascal.org/index.php/topic,66963.msg514647.h
tml#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][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i unit
Unit1; {$mode objfpc}{$H+} interface uses  Classes, SysUtils, Forms,
Controls, Graphics, Dialogs, ExtCtrls, StdCtrls,  BGRAVirtualScreen,
BGRABitmap, BGRABitmapTypes; type  { TForm1 }  TForm1 = class(TForm) 
 BGRAVirtualScreen1: TBGRAVirtualScreen;    btnStart: TButton;   
Timer1: TTimer;    procedure BGRAVirtualScreen1Redraw(Sender: TObject;
Bitmap: TBGRABitmap);    procedure FormCreate(Sender: TObject);   
procedure FormDestroy(Sender: TObject);    procedure
Timer1Timer(Sender: TObject);  private    tt: Single;  public 
end; var  Form1: TForm1;  tex: TBGRABitmap; implementation {$R
*.lfm} { TForm1 } procedure TForm1.FormCreate(Sender: TObject);begin 
try    tex := TBGRABitmap.Create('image2.png'); // 208*208  except   
on E: Exception do      ShowMessage('Erreur de chargement de la
texture : ' + E.Message);  end;end; procedure
TForm1.BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap:
TBGRABitmap);const  CellW = 4;   // 4 x 4 cells  CellH = 4;  SpaceX =
CellW +4;  SpaceY = CellH +4;  Effet_Amp = 16;var  x, y: integer;  x0,
y0: single;  SourceRect: TRect;begin   if tex = nil then exit; 
Bitmap.Fill(BGRA(0,0,0));   for x := 0 to 50 do     //51 x CellW 4 =
204 pixel H    for y := 0 to 50 do  // 51 x CellH 4 = 204 pixel W   
begin      // fx sinus cos      x0 := x * SpaceX + Effet_Amp * Cos(4 *
tt + 0.3 * y) + 100; // 100 X offset of Texture      y0 := y * SpaceY
+ (x / 6 + 2) * Sin(3 * tt + 0.2 * x) + 50; // 50 Yoffset of Texture  
    SourceRect := Rect(                      // get 4*4 pixel from
texture        (x * CellW) mod tex.Width ,            // get 4*4 pixel
from texture        (y * CellH) mod tex.Height ,           // get 4*4
pixel from texture        ((x * CellW) + CellW) mod tex.Width,   //
get 4*4 pixel from texture        ((y * CellH) + CellH) mod tex.Height
  // get 4*4 pixel from texture      );     
Bitmap.PutImagePart(Round(x0), Round(y0),tex, SourceRect, dmSet); //
paste 4x4 pixel to each cells      // PutImagePart is working like
blitter on Amiga copy A + B to C destination    end;end; procedure
TForm1.Timer1Timer(Sender: TObject);begin  tt := tt + 0.025;  //
animate timer  BGRAVirtualScreen1.DiscardBitmap;end; procedure
TForm1.FormDestroy(Sender: TObject);begin  tex.Free;end;end.

----------------------------------------------------------------------
Guva · 2025-05-10 17:23

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

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i program
DVDScreensaver;{$WARN 5027 off : Local variable "$1" is assigned but
never used}uses  raylib, math; const  ScreenWidth = 800;  ScreenHeight
= 600;  CellW = 4;  CellH = 4;  SpaceX = CellW + 4;  SpaceY = CellH +
4;  Effet_Amp = 4; var  tt: Single = 0;  tex: TTexture2D;  running:
Boolean = True;  gridWidth, gridHeight: Integer;  posX, posY: Single; 
speedX, speedY: Single;  currentColor: TColor;  rotation: Single; 
logoSize: Single; procedure LoadResources;begin   if
FileExists('image2.png') then  begin    tex :=
LoadTexture('image2.png');     gridWidth := tex.width div CellW;   
gridHeight := tex.height div CellH;     posX := 0;//ScreenWidth / 2; 
 posY := 0;//ScreenHeight / 2;    speedX := 120;    speedY := 120;   
currentColor := WHITE;    rotation := 0;    logoSize := 1.0;  end 
else  begin    TraceLog(LOG_WARNING, 'Texture file image2.png not
found');    running := False;  end;end; procedure
UnloadResources;begin  UnloadTexture(tex);end; function
GetRandomColor: TColor;begin  case GetRandomValue(0, 6) of    0:
Result := RED;    1: Result := GREEN;    2: Result := BLUE;    3:
Result := YELLOW;    4: Result := PURPLE;    5: Result := ORANGE;   
else Result := SKYBLUE;  end;end; procedure UpdateDVDLogo(dt:
Single);begin   posX := posX + speedX * dt;  posY := posY + speedY *
dt;   if (posX < 0) or (posX > ScreenWidth - gridWidth * SpaceX) then 
begin    speedX := -speedX;    currentColor := GetRandomColor;  end;  
if (posY < 0) or (posY > ScreenHeight - gridHeight * SpaceY) then 
begin    speedY := -speedY;    currentColor := GetRandomColor;  end;  
rotation := rotation + 20 * dt;  if rotation > 360 then rotation :=
rotation - 360;   logoSize := 0.9 + 0.1 * Sin(tt * 2);end; procedure
DrawDVDLogo;var  x, y: Integer;  x0, y0: Single;  SourceRect,
DestRect: TRectangle;  origin: TVector2;begin  origin.x := (gridWidth
* SpaceX) / 2;  origin.y := (gridHeight * SpaceY) / 2;   for x := 0 to
gridWidth - 1 do    for y := 0 to gridHeight - 1 do    begin       x0
:= posX + x * SpaceX + Effet_Amp * Cos(4 * tt + 0.3 * y);      y0 :=
posY + y * SpaceY + (x / 6 + 2) * Sin(3 * tt + 0.2 * x);      
SourceRect := RectangleCreate(        (x * CellW) mod tex.width,     
 (y * CellH) mod tex.height,        CellW,        CellH      );      
DestRect := RectangleCreate(        x0,        y0,        CellW *
logoSize,        CellH * logoSize      );       DrawTexturePro(      
tex,        SourceRect,        DestRect,        Vector2Create(CellW/2
* logoSize, CellH/2 * logoSize),        rotation,        currentColor 
    );    end;end; procedure UpdateAndDraw;var  dt: Single;begin  dt
:= GetFrameTime();    tt += 0.025;   UpdateDVDLogo(dt);  
ClearBackground(DARKGRAY);   DrawDVDLogo;  
DrawText(TextFormat('Position: %.1f, %.1f', posX, posY), 10, 10, 20,
LIGHTGRAY);  DrawText(TextFormat('Speed: %.1f, %.1f', speedX, speedY),
10, 30, 20, LIGHTGRAY);end; begin  InitWindow(ScreenWidth,
ScreenHeight, 'DVD Logo Animation');  SetTargetFPS(60); 
SetRandomSeed(Trunc(GetTime()*1000));  LoadResources;   while running
and not WindowShouldClose do  begin    BeginDrawing;     
UpdateAndDraw;    EndDrawing;  end;   UnloadResources; 
CloseWindow;end.

----------------------------------------------------------------------
Gigatron · 2025-05-10 20:53

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

Code: Pascal  [Select][+][-]window.onload = function(){var x1 =
document.getElementById("main_content_section"); if (x1) { var x =
document.getElementsByClassName("geshi");for (var i = 0; i procedure
DrawDVDLogo;var  x, y: Integer;  x0, y0: Single;  SourceRect,
DestRect: TRectangle;  centerX, centerY, distance, phase, amplitude:
Single;  dx, dy: Single;begin  centerX := (gridWidth * SpaceX) / 2; 
centerY := (gridHeight * SpaceY) / 2;   for x := 0 to gridWidth - 1
do    for y := 0 to gridHeight - 1 do    begin       dx := x * SpaceX
- centerX;      dy := y * SpaceY - centerY;      distance := sqrt(dx *
dx + dy * dy);      phase := distance / 15.0 - tt * 2;      amplitude
:= Effet_Amp * sin(phase);       if distance > 0 then        amplitude
:= amplitude * exp(-distance / 180.0)      else        amplitude :=
0;       if distance > 0 then      begin        dx := dx / distance; 
     dy := dy / distance;        x0 := posX + x * SpaceX + dx *
amplitude;        y0 := posY + y * SpaceY + dy * amplitude;      end 
   else      begin        x0 := posX + x * SpaceX;        y0 := posY +
y * SpaceY;      end;       SourceRect := RectangleCreate(        (x *
CellW) mod tex.width,        (y * CellH) mod tex.height,       
CellW,        CellH      );       DestRect := RectangleCreate(       
x0,        y0,        CellW * logoSize,        CellH * logoSize     
);       DrawTexturePro(        tex,        SourceRect,       
DestRect,        Vector2Create(CellW/2 * logoSize, CellH/2 *
logoSize),        0,        currentColor      );    end;end;