unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, Spin,
BGRAVirtualScreen, BGRABitmap, BGRABitmapTypes,BGRATransform,BGRAGradientScanner,mmsystem;
type
TWaveScanner = class(TBGRAAffineBitmapTransform)
Time: integer;
function GetOffset({%H-}X, Y: Single): Single;
{ fast integer scanning (used by PutImage) }
procedure ScanMoveTo(X, Y: Integer); override;
{ slow floating point scanning }
function ScanAt(X, Y: Single): TBGRAPixel; override;
constructor Create(ASource: TBGRACustomBitmap; ARepeatX,ARepeatY: boolean);
end;
{ TForm1 }
TForm1 = class(TForm)
BGRAVirtualScreen1: TBGRAVirtualScreen;
Timer1: TTimer;
procedure BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
public
w, h: Integer;
fn, fn2,zz: single;
fAddF, fAddV: single;
fStep: Integer;
// bounce var
g : single; // gravity
y,vy : integer; // ypos , vertical y speed
txt_scanner: TWaveScanner;
procedure DrawNormalScroller;
function drawFontChar(charek: Char; x: Integer): Integer;
end;
var
Form1: TForm1;
sn : single;
claudia,dest,txtbitmap :TBGRABitmap;
bitmap_font,tx_scroll_bitmap,dest_bitmap : TBGRABitmap; // images scroll text related
charek : char;
offset: Char;
charSet: String;
fonts_width, fonts_height,pos_y: Integer;
sx, tx, scroll_speed : Integer;
s_text : string = ' GIGATRON FRANCE PROUDLY PRESENTS VERTICAL PICTURE SHIFT DEMO V1.0 CODED ON LAZARUS FPC V 6.0 !!! THERE IS NO PROCESSOR SPARE TIME TO ADD MORE FX ON THE SCREEN !!! REMEMBER AMIGA WITH 7.09 MHZ !!! SEE YOU LATER ';
MyAudio_File: AnsiString;
WavStream : TMemoryStream;
message : Array[0..10] Of String =(' GIGATRON ',
' PRESENTS ',
' ',
' VERTICAL PICTURE SHIFT ',
' DEMO V1.0 ',
' MADE WITH LAZARUS ',
'FREE PASCAL COMPILER V6.0',
' ',
'----------------------- ',
' GO TO SUB-QUANTUM ',
'----------------------- ');
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
claudia := TBGRABitmap.Create('claudia.png');
dest := TBGRABitmap.Create(512,512);
txtbitmap := TBGRABitmap.Create(512,512);
w := claudia.Width;
h := claudia.Height;
fn := 0;
fn2 := 0;
fAddF := 0.05;
fAddV := 0.03;
fStep := 20;
// audio stream
MyAudio_File := 'cbr.wav';
WavStream := TMemoryStream.Create;
WavStream.LoadFromFile(MyAudio_File);
PlaySound(WavStream.Memory, 0, SND_LOOP or SND_NODEFAULT or SND_ASYNC or SND_MEMORY);
// bounce vars init
g := 2.0; // gravity
y := -1024; // far dest bitmap y position at -1024 outside the screen
vy := 0; // vertical y speed !
dest_bitmap := TBGRABitmap.Create(740,32);
bitmap_font := TBGRABitmap.Create('fnt16x16.png');
fonts_width := 16;
fonts_height := 16;
sx := 1000; // start scroll pos x right
charek :=' '; // void always !
offset := ' '; // the first char on s_text = ' ' = space
scroll_speed := 2;
pos_y := 0;
txt_scanner := TWaveScanner.Create(dest_bitmap,false,false);
txt_scanner.Translate(00,490); // scroll text
end;
procedure TForm1.BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
var
i: Integer;
sn, sn2, ww : single;
begin
sn := fn;
sn2 := fn2;
txtbitmap.FontHeight:=40;
txtbitmap.FontAntialias:=false;
txtbitmap.FontName:='AmigaParadox';
for i:=0 to High(message) do
begin
txtbitmap.TextOut(4,14+i*42,message[i],BGRA(50,50,50));
txtbitmap.TextOut(0,10+i*42,message[i],BGRA(255,250,255));
end;
for i := 0 to h-1 do
begin
ww := (cos(fn) * 2 ) * 2 + (sin(fn2) * 2) ;
dest.PutImagePart(0, i + Round(ww), claudia, Rect(0,i,512,i +1),dmSet); // 1 pixel w
dest.PutImagePart(0, i + Round(ww),txtbitmap,Rect(0,i ,512,i+1 ),dmDrawWithTransparency); // 1 pixel w
fn := fn + fAddF + fAddV;
fn2 := fn2 + FAddV;
end;
fn := sn + 0.010; // 0.02;
fn2 := sn2 - 0.08; // 0.03;
bitmap.PutImage(90,y ,dest,dmSet);
DrawNormalScroller;
Bitmap.Fill(txt_scanner,dmLinearBlend);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
vy := vy + Round(g); // bounce loop !
y := y + vy;
if (y > 20 ) then
begin
y := 20 ;
vy := Round(vy *(Frac(-0.80)));
end;
BGRAVirtualScreen1.RedrawBitmap;
end;
function TForm1.drawFontChar(charek: Char; x: Integer): Integer;
var
p, cx, cy, l, r: Integer;
begin
if (x > width) and (x > 0) then
begin
Result := 0;
Exit;
end;
// 16x16
p := Ord(charek) ;
r := (p - Ord(offset)) div (bitmap_font.Width div fonts_width); // nb char 40*8
cx := (p - Ord(offset) -r * (bitmap_font.Width div fonts_width) ) * fonts_width; // dans ce cas là * 40
cy := 0 + (r * fonts_height); // 0
// 8x8
//p := Ord(charek);
//cx := (p - Ord(offset) ) * fonts_width;
//cy := 0; // 0
for l := 0 to fonts_width-1 do
begin
if (cx >= 0) and (x + l <= width) then
begin
dest_bitmap.PutImagePart(x + l , pos_y , bitmap_font, Rect(cx + l, cy, cx + l + 1, cy + fonts_height), dmSet);
end;
end;
Result := 1;
end;
procedure TForm1.DrawNormalScroller;
var
last_char: Char;
x, i: Integer;
koda: Char;
xLimit: Integer;
begin
dec(sx, scroll_speed);
x := sx;
xLimit := width + fonts_width;
for i := 1 to Length(s_text) do
begin
koda := s_text[i];
x := x + fonts_width;
if (x > -fonts_width) and (x < xLimit) then
begin
if drawFontChar(koda, x) = 0 then
Break;
last_char := koda;
end;
end;
if x < 0 then sx := xLimit;
end;
{ TWaveScanner }
function TWaveScanner.GetOffset(X, Y: Single): Single;
begin
// result := 0 * sin((Y + Time) * 30/6 * PI / 180); // no sinus * 0
result := 0; // no sinus * 0
end;
procedure TWaveScanner.ScanMoveTo(X, Y: Integer);
begin
inherited ScanMoveTo(X + round(GetOffset(X, Y)), Y);
end;
function TWaveScanner.ScanAt(X, Y: Single): TBGRAPixel;
begin
Result:=inherited ScanAt(X + GetOffset(X, Y), Y);
end;
constructor TWaveScanner.Create(ASource: TBGRACustomBitmap;
ARepeatX,ARepeatY: boolean);
begin
inherited Create(ASource, ARepeatX, ARepeatY);
Time := 0;
end;
end.
Recent
