unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls,
BGRAVirtualScreen, BGRABitmap, BGRABitmapTypes,libxmp,mmsystem,windows;
const
Version = '0.15';
SampleRate = 44100;
Channels = 2;
BitsPerSample = 16;
BufferSize = 8192; // buffer size=8192 is now Ok !!!
BufferCount = 2;
type
TStarfieldMode = (smVertical, smHorizontal);
TStar = record
X, Y: Single; // Pos x,y
Speed: Single; // speed
Color: TBGRAPixel; // Color
Plane: Integer; // Planes
end;
{ TForm1 }
TForm1 = class(TForm)
BGRAVirtualScreen: TBGRAVirtualScreen;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure BGRAVirtualScreenRedraw(Sender: TObject; Bitmap: TBGRABitmap);
private
ctx: xmp_context;
buffers: array[0..BufferCount-1] of array[0..BufferSize-1] of Byte;
waveHeaders: array[0..BufferCount-1] of TWaveHdr;
currentBuffer: Integer;
FStars: array of TStar;
ScrollMode: TStarfieldMode;
SpeedMultiplier: Single;
procedure InitStars;
procedure UpdateStars;
public
end;
var
Form1: TForm1;
waveOut: HWAVEOUT;
waveHeader: TWaveHdr;
s_data : array [0..255] of integer = ( // sinus data from the champs sidewinder cracktro
80,80,81,83,86,90,94,99,104,110,116,123,130,137,145,152,159,167,173,180,186,192,197,
202,206,209,212,214,215,216,216,216,214,213,210,208,205,201,197,193,189,185,181,177,
173,169,166,162,160,157,155,153,152,151,151,151,151,152,153,155,156,158,160,162,164,
166,168,170,171,172,173,174,174,174,173,172,170,168,166,163,160,156,152,148,143,139,
134,129,125,120,116,112,108,105,102,100,98,97,97,97,98,100,102,106,109,114,119,125,131,
137,144,151,159,166,174,182,189,196,203,209,215,221,226,230,233,236,238,239,239,238,237,
235,232,228,224,219,214,208,202,195,188,181,174,167,160,154,147,141,135,130,125,121,118,
115,112,111,110,109,109,110,112,113,116,118,121,124,128,131,135,139,142,146,149,152,155,
157,159,161,162,163,163,163,163,162,161,160,158,156,154,152,150,148,146,144,142,141,139,
139,138,138,139,139,141,143,145,148,151,155,159,163,168,173,178,183,188,194,199,204,208,
212,216,220,222,225,226,227,227,227,225,223,221,217,213,208,203,197,190,183,176,169,161,
153,145,138,130,123,116,110,104,99,94,90,87,84,83,82);
bob1 : TBGRABitmap;
bob1Scale: array[0..3] of TBGRABitmap; // scaled bobs table 4
logo_g, logo_t, logo_r : TBGRABitmap;
sin_ctg, sin_ctt, sin_ctr : integer;
sc_txt :Array of PChar;
sc_xpos : Single;
implementation
{$R *.lfm}
procedure FillBuffer(bufferIndex: Integer);
begin
xmp_play_buffer(Form1.ctx, @Form1.buffers[bufferIndex][0], BufferSize, 0);
end;
function WaveOutCallback(hwo: HWAVEOUT; uMsg: UINT; dwInstance, dwParam1, dwParam2: DWORD_PTR): DWORD; stdcall;
begin
if uMsg = WOM_DONE then
begin
FillBuffer(Form1.currentBuffer);
waveOutWrite(hwo, @Form1.waveHeaders[Form1.currentBuffer], SizeOf(TWaveHdr));
Form1.currentBuffer := (Form1.currentBuffer + 1) mod BufferCount;
end;
Result := 0;
end;
procedure InitAudio;
var
wFormat: TWaveFormatEx;
i: Integer;
begin
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_LOWEST);
with wFormat do
begin
wFormatTag := WAVE_FORMAT_PCM;
nChannels := Channels;
nSamplesPerSec := SampleRate;
wBitsPerSample := BitsPerSample;
nBlockAlign := (wBitsPerSample * nChannels) div 8;
nAvgBytesPerSec := nSamplesPerSec * nBlockAlign;
cbSize := 0;
end;
if waveOutOpen(@waveOut, WAVE_MAPPER, @wFormat, QWORD(@WaveOutCallback), 0, CALLBACK_FUNCTION) <> MMSYSERR_NOERROR then
raise Exception.Create('Erreur ouverture periph audio');
// buffers
for i := 0 to BufferCount - 1 do
begin
ZeroMemory(@Form1.waveHeaders[i], SizeOf(TWaveHdr));
with Form1.waveHeaders[i] do
begin
lpData := @Form1.buffers[i][0];
dwBufferLength := BufferSize;
end;
waveOutPrepareHeader(waveOut, @Form1.waveHeaders[i], SizeOf(TWaveHdr));
FillBuffer(i);
waveOutWrite(waveOut, @Form1.waveHeaders[i], SizeOf(TWaveHdr));
end;
Form1.currentBuffer := 0;
end;
procedure CloseAudio;
begin
waveOutUnprepareHeader(waveOut, @waveHeader, SizeOf(TWaveHdr));
waveOutClose(waveOut);
end;
{ TForm1 }
procedure TForm1.InitStars;
const
// 4 plans
STAR_COUNT: array[0..3] of Integer = (20,18, 15, 10); // bobs plane distribution Back to Front 0/1/2/3
STAR_SPEED: array[0..3] of Single = ( 2.0, 3.0, 4.0, 5.0);
var
i, j, MaxStars, CStar: Integer;
begin
MaxStars := 0;
for i := 0 to 3 do
Inc(MaxStars, STAR_COUNT[i]);
SetLength(FStars, MaxStars);
CStar := 0;
for i := 0 to 3 do
begin
for j := 0 to STAR_COUNT[i]-1 do
begin
FStars[CStar].X := Random(BGRAVirtualScreen.Width);
FStars[CStar].Y := 50+Random(BGRAVirtualScreen.Height-150);
FStars[CStar].Speed := STAR_SPEED[i];
FStars[CStar].Color := BGRA(255, 255, 255, 255); // pas important
FStars[CStar].Plane := i;
Inc(CStar);
end;
end;
end;
procedure TForm1.UpdateStars;
var
i: Integer;
WW, HH: Integer;
begin
WW := BGRAVirtualScreen.Width;
HH := BGRAVirtualScreen.Height;
for i := 0 to Length(FStars) - 1 do
begin
case ScrollMode of
smVertical:
begin
FStars[i].Y := FStars[i].Y + FStars[i].Speed * SpeedMultiplier;
if SpeedMultiplier > 0 then
begin
if FStars[i].Y > HH+64 then
begin
FStars[i].Y := -64;
FStars[i].X := Random(WW);
end;
end
else
begin
if FStars[i].Y < -64 then
begin
FStars[i].Y := HH+64;
FStars[i].X := Random(WW);
end;
end;
end;
smHorizontal:
begin
FStars[i].X := FStars[i].X + FStars[i].Speed * SpeedMultiplier;
if SpeedMultiplier > 0 then
begin
if FStars[i].X > WW+64 then
begin
FStars[i].X := -64;
FStars[i].Y := 50+Random(HH-150);
end;
end
else
begin
if FStars[i].X < -64 then
begin
FStars[i].X := WW+64;
FStars[i].Y := 50+Random(HH-150);
end;
end;
end;
end;
end;
BGRAVirtualScreen.RedrawBitmap; // refresh
end;
procedure TForm1.BGRAVirtualScreenRedraw(Sender: TObject; Bitmap: TBGRABitmap);
var
i, Pidx : Integer; // bob plane index
begin
// bobs
for i := 0 to Length(FStars) - 1 do
begin
Pidx := FStars[i].Plane;
Bitmap.PutImage(Trunc(FStars[i].X), Trunc(FStars[i].Y), bob1Scale[Pidx], dmLinearBlend);
end;
// Gtr sprites
Bitmap.PutImage(-160+s_data[sin_ctr]*3,140,logo_g,dmLinearBlend);
Bitmap.PutImage(-160+s_data[sin_ctt]*3,140,logo_t,dmLinearBlend);
Bitmap.PutImage(-160+s_data[sin_ctg]*3,140,logo_r,dmLinearBlend);
inc(sin_ctg,1);
sin_ctg := sin_ctg mod 256;
inc(sin_ctt,1);
sin_ctt := sin_ctt mod 256;
inc(sin_ctr,1);
sin_ctr := sin_ctr mod 256;
// rectangles
Bitmap.Rectangle(0,0,BGRAVirtualScreen.Width,80,Bgra(30,140,150),80);
Bitmap.Rectangle(0,440,BGRAVirtualScreen.Width,440+80,Bgra(30,140,150),80);
// Scroll Text
bitmap.FontName:='Courier New';
bitmap.FontStyle := [fsBold];
bitmap.FontHeight := 40;
bitmap.FontAntialias := false;
for i := 0 to Length(sc_txt[0])-1 do
begin
bitmap.TextOut(i*26+sc_xpos,460+Cos(sc_xpos*0.10)*4, sc_txt[0][i],BGRA(250,250,250));
if sc_xpos < -Length(sc_txt[0]) * 26 then sc_xpos := 850;
sc_xpos := sc_xpos -0.02;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
// music xmp
ctx := xmp_create_context;
InitAudio;
if xmp_load_module(ctx, 'defjam.mod') <> 0 then // by Fusion
begin
ShowMessage('Load module error.');
Exit;
end;
xmp_start_player(ctx, SampleRate, 0) ;
bob1 := TBGRABitmap.Create('07.png');
bob1Scale[0] := bob1.Resample(Round(bob1.Width * 0.6), Round(bob1.Height * 0.6), rmFineResample);
bob1Scale[1] := bob1.Resample(Round(bob1.Width * 0.8), Round(bob1.Height * 0.8), rmFineResample);
bob1Scale[2] := bob1.Resample(Round(bob1.Width * 1.2), Round(bob1.Height * 1.2), rmFineResample);
bob1Scale[3] := bob1.Resample(Round(bob1.Width * 1.6), Round(bob1.Height * 1.6), rmFineResample);
ScrollMode := smHorizontal; // init mode H/V
SpeedMultiplier := 3.0; // speed
Caption := 'BGRA BOB DEMO GIGATRON 2025 ';
logo_g := TBGRABitmap.Create('g.png');
logo_t := TBGRABitmap.Create('t.png');
logo_r := TBGRABitmap.Create('r.png');
sin_ctg := 0; // counter start pos 0 at sin data
sin_ctt := 18;// '' start pos 18 at sin data
sin_ctr := 36;// '' start pos 36 at sin data
SetLength(sc_txt, 1);
sc_txt[0] := '........ GIGATRON PRESENTS LAZARUS 8.0 AND FPC SERVAL 6.0 CRACKED ON 03.06.2034 DYNAMIC COMPILATION '+
'CODE PATCHED BY GIGATRON SFX : ESTRAYK GFX : WWW GREETINGS TO ALL MEMBERS OF LAZARUS FORUM MAY THE'+
' FORCES BE WITH YOU SEE YOU ON NEXT PRODUCTION ........ ';
sc_xpos := 850; // text start outside the screen at pos 850
Randomize;
InitStars;
end;
// Free Stars and Bob Table and close audio
procedure TForm1.FormDestroy(Sender: TObject);
var
i: Integer;
begin
for i := 0 to 3 do // 4 bob scale table !
bob1Scale[i].Free;
bob1.Free;
SetLength(FStars, 0);
CloseAudio;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
UpdateStars;
end;
end.
Recent
