unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls,
BGRABitmap, BGRABitmapTypes, BGRAVirtualScreen; uplaysound;
const
ascii : Array [0..58] of integer = (26,37,99,99,99,99,99,41,42,43,99,99,44,99,38,99,27,28,29,30,31,32,33,34,35,36,40,99,99,99,99,39,99,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25);
cop_col:Array[0..245] of String =('#000066','#000055','#000044','#000033','#000022','#000011','#000011','#000022','#000033',
'#000044','#000055','#000066','#000077','#000088','#000099','#0000aa','#0000bb','#0000cc',
'#0000dd','#0000ee','#0000ff','#1111ff','#2222ff','#3333ff','#4444ff','#5555ff','#6666ff',
'#7777ff','#8888ff','#9999ff','#aaaaff','#bbbbff','#ccccff','#ddddff','#eeeeff','#eeffff',
'#ffffff','#ffffff','#eeffff','#eeeeff','#ddddff','#ccccff','#bbbbff','#aaaaff','#9999ff',
'#8888ff','#7777ff','#6666ff','#5555ff','#4444ff','#3333ff','#2222ff','#1111ff','#0000ff',
'#0000ee','#0000dd','#0000cc','#0000bb','#0000aa','#000099','#000088','#000077','#000066',
'#000055','#000044','#000033','#000022','#000011','#000022','#000033','#000044','#000055',
'#000066','#000077','#000088','#000099','#0000aa','#0000bb','#0000cc','#0000dd','#0000ee',
'#0000ff','#1111ff','#2222ff','#3333ff','#4444ff','#5555ff','#6666ff','#7777ff','#8888ff',
'#9999ff','#aaaaff','#bbbbff','#ccccff','#ddddff','#eeeeff','#eeffff','#ffffff','#ffffff',
'#eeffff','#eeeeff','#ddddff','#ccccff','#bbbbff','#aaaaff','#9999ff','#8888ff','#7777ff',
'#6666ff','#5555ff','#4444ff','#3333ff','#2222ff','#1111ff','#0000ff','#0000ee','#0000dd',
'#0000cc','#0000bb','#0000aa','#000099','#000088','#000077','#000066','#000055','#000044',
'#000033','#000022','#000011','#000011','#000022','#000033','#000044','#000055','#000066',
'#000077','#000088','#000099','#0000aa','#0000bb','#0000cc','#0000dd','#0000ee','#0000ff',
'#1111ff','#2222ff','#3333ff','#4444ff','#5555ff','#6666ff','#7777ff','#8888ff','#9999ff',
'#aaaaff','#bbbbff','#ccccff','#ddddff','#eeeeff','#eeffff','#ffffff','#ffffff','#eeffff',
'#eeeeff','#ddddff','#ccccff','#bbbbff','#aaaaff','#9999ff','#8888ff','#7777ff','#6666ff',
'#5555ff','#4444ff','#3333ff','#2222ff','#1111ff','#0000ff','#0000ee','#0000dd','#0000cc',
'#0000bb','#0000aa','#000099','#000088','#000077','#000066','#000055','#000044','#000033',
'#000022','#000011','#000022','#000033','#000044','#000055','#000066','#000077','#000088',
'#000099','#0000aa','#0000bb','#0000cc','#0000dd','#0000ee','#0000ff','#1111ff','#2222ff',
'#3333ff','#4444ff','#5555ff','#6666ff','#7777ff','#8888ff','#9999ff','#aaaaff','#bbbbff',
'#ccccff','#ddddff','#eeeeff','#eeffff','#ffffff','#ffffff','#eeffff','#eeeeff','#ddddff',
'#ccccff','#bbbbff','#aaaaff','#9999ff','#8888ff','#7777ff','#6666ff','#5555ff','#4444ff',
'#3333ff','#2222ff','#1111ff','#0000ff','#0000ee','#0000dd','#0000cc','#0000bb','#0000aa',
'#000099','#000088','#000077');
var
CharImage: TBGRABitmap;
ScrollSpeed: integer = 2;
ScrollCounter: integer = 1;
CharWidth : integer = 30;
CharW : integer = 30;
CharHeight : integer = 48;
CharsPerLine : integer = 240;
ScrollText : String = ' .... GIGATRON THE LEADER PRESENTS BITMAP FONT SCROLLER DEMO CODED WITH LAZARUS PASCAL GREETINGS TO PUMA, JAGUAR, SERVAL, LYNX, CARACAL, PANTHER, OCELOT, CHEETAH, WILD CAT, ... FONT FROM THE CHAMPS CRACKTRO AMIGA IN 1988 RELEASE DATE LATE ON (( 22.04.2024 )) SEE YOU .....';
hexColor: string;
red, green, blue: Byte;
j,pause,snd_timer : integer;
type
{ TForm1 }
TForm1 = class(TForm)
BGRAVirtualScreen1: TBGRAVirtualScreen;
playsound1: Tplaysound;
Timer1: TTimer;
procedure BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
// playsound1.Execute; // play once when form created !
CharImage := TBGRABitmap.Create('font2x.png');
CharImage.SetSize(30,2226);
j:=0;
pause := 0;
end;
procedure HexToRGB(hex: string; var r, g, b: Byte);
begin
r := StrToInt('$' + Copy(hex, 2, 2));
g := StrToInt('$' + Copy(hex, 4, 2));
b := StrToInt('$' + Copy(hex, 6, 2));
end;
procedure TForm1.BGRAVirtualScreen1Redraw(Sender: TObject; Bitmap: TBGRABitmap);
var
I, Chr: Integer;
CharX, CharY: Integer;
ScrollOffset: Integer;
begin
Bitmap.Fill(BGRAPixelTransparent);
// raster bars cycle colors
for i := 0 to 20 do
begin
hexColor := cop_col[i+j];
HexToRGB(hexColor, red, green, blue);
Bitmap.FillRect(0,242+i*2,640,242+i*2-2,RGBToColor(red,green,blue));
end;
inc(pause);
if (pause>=1) then
begin
inc(j);
pause := 0;
if(j>=184) then j:=0;
end;
// Bitmap Scrolling copy bitmap char with correct ascii code , x,y,x1,y1 like Amiga blitter
ScrollOffset := ScrollCounter ;
for I := 0 to 24 do
begin
Chr := Ord(ScrollText[I]);
CharX := ((I - 1) mod CharsPerLine) * CharWidth - ScrollOffset ;
CharY := ((I - 1) div CharsPerLine) * CharHeight ;
Bitmap.PutImagePart(CharX , 240+CharY , CharImage, Rect(0, ascii[Chr-32]*CharHeight , CharW, ascii[Chr-32]*CharHeight+CharHeight), dmDrawWithTransparency);
end;
ScrollCounter := ScrollCounter + ScrollSpeed;
if ScrollCounter >= CharWidth then
begin
ScrollCounter := ScrollCounter - CharWidth;
ScrollText := Copy(ScrollText,2, Length(ScrollText) - 1) + ScrollText[1];
end;
// play sound every xxx sec
// inc(snd_timer);
// if(snd_timer>500) then
// begin
// snd_timer :=0;
// playsound1.Execute;
// end
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
BGRAVirtualScreen1.RedrawBitmap;
end;
procedure TForm1.FormDestroy(Sender: TObject);
// libere tout !!
begin
//playsound1.Free;
CharImage.Free;
end;
end.