unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls,
BGRAVirtualScreen, BGRABitmap, BGRABitmapTypes,BGRAGradientScanner,DateUtils,BGRACanvas2D, mmsystem;
type
TTextPages = array of array of string;
{ TForm1 }
TForm1 = class(TForm)
BGRAVirtualScreen1: TBGRAVirtualScreen;
Timer1: TTimer;
procedure BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
FMsgBitmap : TBGRABitmap;
FTextPages : TTextPages;
FPageIndex : integer;
FLineIndex : integer;
FCharIndex : integer;
FGradient : TBGRAGradientScanner;
FGradientCount : integer;
FAnimateColours : boolean;
protected
procedure UpdateGradientColoursAnim;
procedure UpdateText;
procedure Update;
procedure drawStar(ctx: TBGRACanvas2D;cx, cy, spikes : integer; outerRadius, innerRadius, rotation : single;style : TBGRAPixel);
public
MyAudio_File: AnsiString;
WavStream : TMemoryStream;
end;
var
Form1: TForm1;
rt : single;
x_pos,y_pos : integer;
var
pages : TTextPages =
(
(
' TYPE WRITER DEMO ',
' WRITTEN BY GIGATRON ',
' IMPROVED BY THE GREAT TRON',
' ',
' SFX BY DIRK / LENGEND ',
' LAZARUS FREE PASCAL ',
' COMPILER ',
' ',
' CODING IS THE PASSION OF ',
' CORTEX ',
' --------------------------',
' SEE YOU ON NEXT ',
' PRODUCTION ',
' --------------------------',
' '
),
(
' **************************',
' * GREETINGS LIST !! *',
' * *',
' *CIRCULAR LAINZ TRON *',
' *JOSH KODEZWERG HUKKA *',
' * GUVACODE RAYSAN5 *',
' *MATTIAS MARCOV MARTIN-FR*',
' *PASCALDRAGON BLACK STAR *',
' *MIPS PURPLE-LANTERN DIRK*',
' *CUBIC-CIRCLE P.M.A DDC*',
' *AXE-X TRONIC-DESIGN *',
' *CRYSTAL-DUST SUB-SERO *',
' *ANNY SUB-QUANTUM NEW-BCX*',
' * AND THE REST WE FORGOT*',
' **************************',
' '
)
);
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
FTextPages := pages;
FMsgBitmap := TBGRABitmap.Create(640, 480);
// font used to display message !
FMsgBitmap.FontName:='AmigaDigital8';
FMsgBitmap.FontHeight:=36;
// Message parameters
FPageIndex := 0; // page index
FLineIndex := 0; // line index of current page
FCharIndex := 0; // (horizontal/column) character index of current line
FGradientCount := 32; // amount of colourpoints in gradient (is it possible to retrieve that from the gradient itself ?)
FGradient := TBGRAGradientScanner.Create
(
BGRA(255,255,255), BGRA(0,60,255),
gtReflected,
PointF(0,0) , PointF(0,FGradientCount-1),
True,True
);
FAnimateColours := true;
rt := 0.0;
x_pos :=100;
y_pos :=20;
// audio stream
MyAudio_File := 'wanderingmind.wav';
WavStream := TMemoryStream.Create;
WavStream.LoadFromFile(MyAudio_File);
PlaySound(WavStream.Memory, 0, SND_NODEFAULT or SND_ASYNC or SND_MEMORY);
end;
procedure TForm1.BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
var
ctx: TBGRACanvas2D;
begin
ctx := Bitmap.Canvas2D;
// les etoiles !
drawStar(ctx, x_pos+220,y_pos+225, 7, 110.0, 170.0, rt*1.0,BGRA(77,88,99));
drawStar(ctx, x_pos+200,y_pos+210, 7, 110.0, 170.0, rt*1.3,BGRA(44,55,66));
drawStar(ctx, x_pos+210,y_pos+220, 7, 110.0, 170.0, rt*1.6,BGRA(66,77,88));
Bitmap.StretchPutImage(Bitmap.ClipRect, FMsgBitmap, dmDrawWithTransparency);
UpdateGradientColoursAnim;
update;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
rt := rt + 0.02; // stars rotation
BGRAVirtualScreen1.RedrawBitmap;
end;
procedure TForm1.UpdateText;
type
TTypeWriterStatus = (twsTyping, twsViewPage, twsClearPage, twsEmptyPage);
const
TypingDelay = 50; // typing delay in milliseconds
ViewPageTime = 3000; // Time in milliseconds to view text page
ClearUpdateDelay = 50; // update clear delay in milliseonds
EmptyPageTime = 1000; // Time in milliseconds to view empty page
ClearDistance = 2; // how many lines to clear for each iteration
Status : TTypeWriterStatus = twsEmptyPage;
LDT : TDateTime = 0.0;
ClearIndex : integer = 0;
var
CDT : TDateTime;
msb : int64;
ch : Char;
doType : boolean = false;
begin
CDT := now;
msb := MilliSecondsBetween(CDT, LDT);
// process delay based on Status
case Status of
twsTyping : if msb > TypingDelay then
begin
LDT := CDT; // update Last DateTime
doType := true;
end else exit;
twsViewPage : if msb > ViewPageTime then
begin
LDT := CDT; // update Last DateTime
Status := twsClearPage;
exit;
end else exit;
twsClearPage : if msb > ClearUpdateDelay then
begin
LDT := CDT; // update Last DateTime
if ClearIndex < FMsgBitmap.Height then
begin
FMsgBitmap.FillRect(Bounds(0,ClearIndex, FMsgBitmap.Width, ClearDistance),BGRA(0,0,0,0),dmSet); // fill rectangle fx !
ClearIndex += ClearDistance;
end
else
begin
status := twsEmptyPage;
ClearIndex := 0;
end;
exit;
end else exit;
twsEmptyPage : if msb > EmptyPageTime then
begin
LDT := CDT; // update Last DateTime
Status := twsTyping;
if (FPageIndex = 0) and (FLineIndex = 0) and (FCharIndex = 0)
then FAnimateColours := not(FAnimateColours);
exit;
end else exit;
end;
// when display next character requested
if doType then
begin
doType := false;
// if there is any character left in the current line of the current page to be printed
if FCharIndex < Length(FTextPages[FPageIndex][FLineIndex]) then
begin
// display only upcase characters
ch := Upcase(FTextPages[FPageIndex][FLineIndex][succ(FCharIndex)]);
FMsgBitmap.TextOut(FCharIndex*22,FLineIndex*28, ch, FGradient);
// next character (index)
inc(FCharIndex);
end
else // when no more characters left in line
begin
// next line index
inc(FLineIndex);
// reset character index
FCharIndex :=0;
// when exceeding the number of lines of the current page
if FLineIndex >= Length(FTextPages[FPageIndex]) then
begin
// reset line index
FLineIndex := 0;
// next page index
inc(FPageIndex);
// if no pages left then reset to first page index
if FPageIndex >= Length(FTextPages) then
begin
FPageIndex := 0;
end;
// switch status to view current typed text
Status := twsViewPage;
end;
end;
end; // next character
end;
procedure TForm1.UpdateGradientColoursAnim;
const
gindex : integer = 0; // gradient index to start with
gspeed = 1; // gradient speed (added to gradient index)
var
x,y : integer;
p1 : PBGRAPixel;
p2 : PDWord absolute p1;
goffset : integer = 0;
g : integer;
begin
for y := 0 to FMsgBitmap.Height-1 do
begin
g := (gindex + y) mod FGradientCount;
p1 := FMsgBitmap.Scanline[y];
for x := 0 to FMsgBitmap.Width-1 do // for x := (FMsgBitmap.Width shr 1) to (FMsgBitmap.Width-1) do
begin
if p2[x] <> 0
then p1[x] := FGradient.ScanAt(0,g);
end;
end;
FMsgBitmap.InvalidateBitmap; // pixels changed by direct access so invalidate
gindex := (gindex + gspeed) mod FGradientCount; // High(FRasterColours);
end;
procedure TForm1.Update;
const
AnimColoursFrameDelay = 1;
counter : integer = AnimColoursFrameDelay;
cursorFrameindex : integer = 0;
cursorRect : TRect = (Left :0; Top: 0; Right: 0; Bottom: 0);
var
cx,cy: integer;
begin
// in order to prevent the colour animation from applying itself to the
// cursor the (previous) cursor needs to be removed first
FMsgBitmap.FillRect(cursorRect, BGRA($00,$00,$00, $00));
UpdateText;
if FAnimateColours then
begin
dec(counter);
if counter <= 0 then
begin
counter := AnimColoursFrameDelay;
UpdateGradientColoursAnim;
end;
end;
// update cursor
cursorFrameindex := (cursorFrameindex + 1) mod 7;
cx := (FCharIndex -1) * 22;
cy := (FLineIndex -1) * 28 + 12; // + 8 correction (undertermined value)
cursorRect := Bounds
(
cx + 32 - cursorFrameindex*4 shr 1,
cy + 32 - cursorFrameindex*4 shr 1,
cursorFrameindex*4,
cursorFrameindex*4
);
FMsgBitmap.FillRect(cursorRect, BGRA($FF,$FF,$FF));
end;
procedure TForm1.DrawStar(ctx: TBGRACanvas2D; cx, cy, spikes: Integer; outerRadius, innerRadius, rotation: single;style : TBGRAPixel);
var
rot, step, x, y: single;
i: Integer;
begin
rot := Pi / 2 * 3 + rotation;
step := Pi / spikes;
ctx.BeginPath;
x := cx + cos(rot) * outerRadius;
y := cy + sin(rot) * outerRadius;
ctx.MoveTo(x, y);
for i := 0 to spikes - 1 do
begin
x := cx + cos(rot) * outerRadius;
y := cy + sin(rot) * outerRadius;
ctx.LineTo(x, y);
rot := rot + step;
x := cx + cos(rot) * innerRadius;
y := cy + sin(rot) * innerRadius;
ctx.LineTo(x, y);
rot := rot + step;
end;
x := cx + cos(rot) * outerRadius;
y := cy + sin(rot) * outerRadius;
ctx.LineTo(x, y);
ctx.ClosePath;
ctx.LineWidth := 50;
ctx.strokeStyle(style);
ctx.Stroke;
ctx.fillStyle ('rgba(0,0,0,0)');;
ctx.Fill;
end;
end.
Recent
