Delphi - Cute Plasma Effect

[REinvestigator]

اقتباس من الموضوع الأصلي لــ Sn!per X
 

السلام عليكم
Delphi - Cute Plasma Effect

كود:

(*
 Project: Cute Plasma Effect
 Original C++ Source: http://www.hardforum.ru/t80882/
 Ported to delphi by: Sn!per X ^ AT4RE
 Code Type: Delphi / WinAPI
 Release Date: 21-11-2015
*)
program CutePlasmaEffect;


uses Windows, Messages;


Const
 progname = 'Cute plasma';


type
 TIntegerList = array[0..$00FFFFFF] of Integer;
 PIntegerList = ^TIntegerList;


var
 SINTAB : Array [0..255] of Extended;
 pDC : HDC;
 old, ourbitmap: HBITMAP;
 framebuf: PIntegerList;


Procedure render_effect(tick: integer);
var i,j,k: integer;
begin
 tick := round(tick / 4);
 k:= 0;
 For i:=0 To 200-1 do
 begin
   For j:=0 To 320-1 do
   begin
     framebuf^[k] := (RGB(round(SINTAB[(i+tick) and $ff]),
                          round(SINTAB[(j-tick) and $ff]),
                          round(SINTAB[round((SINTAB[tick and $ff])+(k shr 6)) and $ff])));
     Inc(k);
   end;
 end;
end;


Procedure render(HDC: hDC);
begin
 render_effect(GetTickCount());
 BitBlt(hDC,0,0,320,200,pDC,0,0,SRCCOPY);
end;


Procedure deinit_framebuf();
begin
 SelectObject(pDC,old);
 DeleteDC(pDC);
 DeleteObject(ourbitmap);
End;


Procedure init_framebuf();
var
 xHDC: hDC;
 tbitmapinfo : BITMAPINFO;
begin
 xhDC := CreateCompatibleDC(0);
 tbitmapinfo.bmiHeader.biSize:=sizeof(BITMAPINFOHEADER);
 tbitmapinfo.bmiHeader.biWidth:=320;
 tbitmapinfo.bmiHeader.biHeight:=-200; //* top-down */
 tbitmapinfo.bmiHeader.biPlanes:=1;
 tbitmapinfo.bmiHeader.biBitCount:=32;
 tbitmapinfo.bmiHeader.biCompression:=BI_RGB;
 tbitmapinfo.bmiHeader.biSizeImage:=0;
 tbitmapinfo.bmiHeader.biClrUsed:=256;
 tbitmapinfo.bmiHeader.biClrImportant:=256;
 ourbitmap:=CreateDIBSection(xhDC,tbitmapinfo,DIB_RGB_COLORS,Pointer(framebuf),0,0);
 pDC:=CreateCompatibleDC(0);
 old:=SelectObject(pDC,ourbitmap);
 DeleteDC(xhDC);
end;


Function winproc(hWnd,Msg:Longint; wParam : WPARAM; lParam: LPARAM):Longint; stdcall;
var
 xHDC: hDC;
 PtStr: PAINTSTRUCT;
Begin
 Result:= 0;
 Case (Msg) of
   WM_DESTROY:
   Begin
     deinit_framebuf();
     PostQuitMessage(0);
     KillTimer (hWnd, 1);
     Exit;
   End;
   WM_CREATE:
   Begin
     SetTimer (hWnd, 1, 1, nil);
     init_framebuf();
     Exit;
   End;
   WM_TIMER:
   Begin
     InvalidateRgn(hWnd,0, false);
     UpdateWindow (hWnd);
     Exit;
   End;
   WM_PAINT:
   Begin
     xhDC:=BeginPaint(hWnd,PtStr);
     render(xhDC);
     EndPaint(hWnd,PtStr);
     Exit;
   End;
 End;
 Result := DefWindowProc(hWnd, Msg, wParam, lParam);
end;


var winclass: WNDCLASSEX;
   iHWND: hWnd;
   iMSG: msg;
   i : Integer;
begin
 for i:=0 to 255-1 Do
   SINTAB[i]:=sin(((i+1)*3.14159265359)/128)*127+128;


 winclass.cbSize:=sizeof(WNDCLASSEX);
 winclass.style:=CS_DBLCLKS;
 winclass.lpfnWndProc:=@winproc;
 winclass.cbClsExtra:=0;
 winclass.cbWndExtra:=0;
 winclass.hInstance:=hInstance;
 winclass.hIcon:=LoadIcon(0,IDI_WINLOGO);
 winclass.hCursor:=LoadCursor(0,IDC_NO);
 winclass.hbrBackground:=0;
 winclass.lpszMenuName:=0;
 winclass.lpszClassName:=progname;
 winclass.hIconSm:=0;


 if RegisterClassEx(winclass) = 0 Then
   Exit;


 ihWnd:= CreateWindow(
   progname,
   progname,
   WS_SYSMENU or WS_CAPTION or WS_BORDER or WS_OVERLAPPED or WS_VISIBLE or WS_MINIMIZEBOX,
   CW_USEDEFAULT,
   0,
   320+2,
   200+16+2,
   0,
   0,
   hInstance,
   0);
 ShowWindow(ihWnd,SW_SHOW);
 UpdateWindow(ihWnd);
 while GetMessage(iMSG,0,0,0) do
 Begin
   TranslateMessage(iMSG);
   DispatchMessage(iMSG);
 end;
End;

.

BTW, Snapshot image is not good quality