Тема: Moving Colored Circles demo
В этом примере происходит анимация движущихся цветных кружков.
Есть вариант, использующий библиотеку Buf2D:
program Buf2dMovingColoredCircles;
uses
KolibriOS;
function MemoryAllocate(Bytes: LongWord): Pointer; stdcall;
asm
push ecx
push ebx
mov eax, 68
mov ebx, 12
mov ecx, Bytes
int 64
pop ebx
pop ecx
end;
function MemoryReallocate(MemPtr: Pointer; Bytes: LongWord): Pointer; stdcall;
asm
push ebx
push ecx
push edx
mov eax, 68
mov ebx, 20
mov ecx, Bytes
mov edx, MemPtr
int 64
pop edx
pop ecx
pop ebx
end;
function MemoryFree(MemPtr: Pointer): LongWord; stdcall;
asm
push ecx
push ebx
mov eax, 68
mov ebx, 13
mov ecx, MemPtr
int 64
pop ebx
pop ecx
end;
type
Proc = procedure;
procedure InitLibrary(LibInit: Proc); stdcall;
const
LIB_PATH = '/sys/lib/';
type
PNameAddr = ^TNameAddr;
TNameAddr = packed record
Name: PAnsiChar;
Addr: Pointer;
end;
PAddrName = ^TAddrName;
TAddrName = packed record
Addr: Pointer;
Name: PAnsiChar;
end;
function StrEqual(Str1, Str2: PAnsiChar): Boolean;
begin
while (Str1^ = Str2^) and (Str1^ <> #0) do
begin
Inc(Str1);
Inc(Str2);
end;
Result := Str1^ = Str2^;
end;
procedure StrCopy(StrFrom, StrTo: PAnsiChar);
begin
while (StrFrom^ <> #0) do
begin
StrTo^ := StrFrom^;
Inc(StrFrom);
Inc(StrTo);
end;
end;
function DLLLoad(ImportTable: PAddrName): LongInt; stdcall;
var
ExportTable: PNameAddr;
ProcAddr: Pointer;
Name: PPAnsiChar;
LibPath: array [0..32] of AnsiChar;
begin
Result := 1;
StrCopy(LIB_PATH, LibPath);
while ImportTable.Addr <> nil do
begin
StrCopy(ImportTable.Name, Pointer(LongInt(@LibPath) + Length(LIB_PATH)));
ExportTable := LoadLibrary(LibPath);
if ExportTable = nil then
Exit;
Name := PPAnsiChar(ImportTable.Addr);
while Name^ <> nil do
begin
ProcAddr := GetProcAddress(ExportTable, Name^);
if ProcAddr <> nil then
Pointer(Name^) := ProcAddr
else
Exit;
Inc(Name);
end;
if StrEqual(ExportTable.Name, 'lib_init') then
InitLibrary(ExportTable.Addr);
Inc(ImportTable);
end;
Result := 0;
end;
asm
pushad
mov eax, offset MemoryAllocate
mov ebx, offset MemoryFree
mov ecx, offset MemoryReallocate
mov edx, offset DLLLoad
call LibInit
popad
end;
const
WS_NO_DRAW = $1000000;
BACK_COLOR = $00000000;
type
PBuf2DBuffer = ^TBuf2DBuffer;
TBuf2DBuffer = packed record
Img: Pointer;
Left: SmallInt;
Top: SmallInt;
Width: LongWord;
Height: LongWord;
Color: LongWord;
BPP: Byte;
end;
HSVTriple = packed record
Hue: Word;
Sat: Byte;
Val: Byte;
end;
RGBQuad = packed record
Blue: Byte;
Green: Byte;
Red: Byte;
_: Byte;
end;
var
Buf2D: Pointer;
Buf2DLibInit: procedure;
buf2d_create: procedure(var Buffer: TBuf2DBuffer); stdcall;
buf2d_draw: procedure(var Buffer: TBuf2DBuffer); stdcall;
buf2d_clear: procedure(var Buffer: TBuf2DBuffer; Color: LongWord); stdcall;
buf2d_set_pixel: procedure(var Buffer: TBuf2DBuffer; X, Y: LongInt; Color: LongWord); stdcall;
WndWidth: LongWord;
WndHeight: LongWord;
Buf2DBuffer: TBuf2DBuffer = (Left: 0; Top: 0; Color: BACK_COLOR; BPP: 24); // определяем 24-битный буфер с цветом фона BACK_COLOR
Freq: LongWord = 100; // это всё
Instant: Single = 0.0; // нужно для удержания FPS в пределах
MaxFrameRate: Single = 15.0; // от 8-ми
MinFrameRate: Single = 8.0; // до 15-ти
SleepTime: LongWord = 0; // иначе у некоторых будет рисоваться слишком быстро
FrameStart: LongWord; // как со старыми DOS-играми, некоторые из них слишком быстро работают на современных компьютерах
procedure QueryPerf;
var
Diff: LongWord;
asm
call GetTickCount
sub eax, FrameStart
mov Diff, eax
fild Diff
fild Freq
fdivrp
fstp Instant
call GetTickCount
mov FrameStart, eax
end;
procedure Waiting;
asm
fld MaxFrameRate
fld Instant
fcomip st(0), st(1)
fstp st(0)
jna @maybe_dec
inc SleepTime
jmp @sleep
@maybe_dec:
fld MinFrameRate
fld Instant
fcomip st(0), st(1)
fstp st(0)
jnc @sleep
cmp SleepTime, 0
jz @sleep
dec SleepTime
@sleep:
push SleepTime
call Sleep
end;
function Sin(Value: Extended): Extended;
asm
FLD Value
FSIN
end;
function Cos(Value: Extended): Extended;
asm
FLD Value
FCOS
end;
function Round(Value: Extended): Int64;
asm
FLD Value
SUB ESP, 8
FISTP qword ptr [ESP]
POP EAX
POP EDX
end;
(* H = [0..360]; S = [0..255]; V = [0..255] *)
function HSV2RGB(H, S, V: LongWord): LongWord;
const
D: LongWord = 255 * 60;
var
F, VS: LongWord;
begin
with RGBQuad(Result) Do
begin
if S = 0 then
begin
Red := V;
Green := V;
Blue := V;
end
else
begin
if H = 360 then H := 0;
F := H mod 60;
H := H div 60;
VS := V * S;
case H of
0:
begin
Red := V;
Green := V - (VS * (60 - F)) div D;
Blue := V - VS div 255;
end;
1:
begin
Red := V - (VS * F) div D;
Green := V;
Blue := V - VS div 255;
end;
2:
begin
Red := V - VS div 255;
Green := V;
Blue := V - (VS * (60 - F)) div D;
end;
3:
begin
Red := V - VS div 255;
Green := V - (VS * F) div D;
Blue := V;
end;
4:
begin
Red := V - (VS * (60 - F)) div D;
Green := V - VS div 255;
Blue := V;
end;
5:
begin
Red := V;
Green := V - VS div 255;
Blue := V - (VS * F) div D;
end;
end;
end;
end;
end;
Const
PIECE_COUNT = 17;
PIECE_MULTIPLIER = 0.375;
ARC_COUNT = 12;
var
Angle: Double = PI;
bAngle: Double = 0.0;
mAngle: Double = 0.0;
sAngle: Double = 0.0;
dA: Double = PI * 2 / ARC_COUNT;
X: LongInt;
Y: LongInt;
R: Double;
procedure DrawFilledCircle(CX, CY, R, FillColor: LongInt);
var
X, Y: LongInt;
begin
for Y := -R to R do
for X := -R to R do
if X * X + Y * Y - R * R <= 0 then
buf2d_set_pixel(Buf2DBuffer, CX + X, CY + Y, FillColor)
else
if X * X + Y * Y - R * R <= R then
buf2d_set_pixel(Buf2DBuffer, CX + X, CY + Y, (FillColor shr 1) and $007F7F7F);
end;
procedure Circle(FillColor, X, Y, R: LongInt);
begin
DrawFilledCircle(X + R, Y - R, R, FillColor);
end;
procedure CircleChain(x0, y0: LongInt; Angle, dA, dR: Double);
var
X, Y, i: LongInt;
begin
for i := 1 to PIECE_COUNT do
begin
X := Round(Cos(Angle) * (R / dR) + x0);
Y := Round(Sin(Angle) * (R / dR) + y0);
Angle := Angle + dA;
Circle(HSV2RGB(LongWord(Round(Sqrt(Sqr(X - Buf2DBuffer.Width / 2) + Sqr(Y - Buf2DBuffer.Height / 2)))) mod 360, 255, 255), X, Y, Round(i * PIECE_MULTIPLIER));
end;
end;
procedure Drawing;
var
i: LongInt;
begin
with Buf2DBuffer do
begin
if Width < Height then
R := Width
else
R := Height;
R := R * 1.075;
sAngle := sAngle + PI * 2 / 32;
mAngle := mAngle + PI * 2 / 48;
bAngle := bAngle + PI * 2 / 64;
for i := 1 to ARC_COUNT do
begin
Angle := Angle + dA;
sAngle := sAngle + dA;
X := Round(Cos(Angle) * (R / 4.347826) + Width / 2);
Y := Round(Sin(Angle) * (R / 4.347826) + Height / 2);
CircleChain(X, Y, sAngle, PI / 15, 10.0);
end;
for i := 1 to ARC_COUNT do
begin
Angle := Angle + dA;
mAngle := mAngle + dA;
X := Round(Cos(Angle + PI / 16) * (R / 4.255319) + Width / 2);
Y := Round(Sin(Angle + PI / 16) * (R / 4.255319) + Height / 2);
CircleChain(X, Y, mAngle, PI / 18, 6.666666);
end;
for i := 1 to ARC_COUNT do
begin
Angle := Angle + dA;
bAngle := bAngle + dA;
X := Round(Cos(Angle + PI / 8) * (R / 4.166666) + Width / 2);
Y := Round(Sin(Angle + PI / 8) * (R / 4.166666) + Height / 2);
CircleChain(X, Y, bAngle, PI / 21, 5.0);
end;
end;
buf2d_draw(Buf2DBuffer); // выводим на экран
buf2d_clear(Buf2DBuffer, BACK_COLOR); // закрашиваем буфер цветом фона
end;
procedure DrawCircles;
begin
QueryPerf;
Drawing;
Waiting;
end;
procedure On_Redraw;
begin
BeginDraw;
DrawWindow(0, 0, WndWidth, WndHeight, nil, 0, WS_NO_DRAW, CAPTION_NONMOVABLE);
EndDraw;
end;
begin
Buf2D := LoadLibrary('/sys/lib/buf2d.obj');
buf2dLibInit := GetProcAddress(Buf2D, 'lib_init');
buf2d_create := GetProcAddress(Buf2D, 'buf2d_create');
buf2d_draw := GetProcAddress(Buf2D, 'buf2d_draw');
buf2d_set_pixel := GetProcAddress(Buf2D, 'buf2d_set_pixel');
buf2d_clear := GetProcAddress(Buf2D, 'buf2d_clear');
InitLibrary(Buf2DLibInit);
with GetScreenSize do
begin
WndWidth := Width;
WndHeight := Height;
end;
with Buf2DBuffer do
begin
Width := WndWidth;
Height := WndHeight;
end;
buf2d_create(Buf2DBuffer); // создаём буфер
FrameStart := GetTickCount - 1;
SetEventMask(EM_REDRAW + EM_KEY);
while True do
case CheckEvent of
REDRAW_EVENT:
On_Redraw;
KEY_EVENT:
Break;
else
DrawCircles;
end;
end.А есть вариант, не использующий никаких библиотек:
program MovingColoredCircles;
uses
KolibriOS;
const
WS_NO_DRAW = $1000000;
BACK_COLOR = $00000000;
type
TImageBuffer = packed record
Left: LongInt;
Top: LongInt;
Width: LongWord;
Height: LongWord;
Buffer: Pointer;
end;
HSVTriple = packed record
Hue: Word;
Sat: Byte;
Val: Byte;
end;
RGBQuad = packed record
Blue: Byte;
Green: Byte;
Red: Byte;
_: Byte;
end;
var
WndWidth: LongWord;
WndHeight: LongWord;
ImageBuffer: TImageBuffer;
Freq: LongWord = 100; // это всё
Instant: Single = 0.0; // нужно для удержания FPS в пределах
MaxFrameRate: Single = 15.0; // от 8-ми
MinFrameRate: Single = 8.0; // до 15-ти
SleepTime: LongWord = 0; // иначе у некоторых будет рисоваться слишком быстро
FrameStart: LongWord; // как со старыми DOS-играми, некоторые из них слишком быстро работают на современных компьютерах
// устанавливает цвет Color в точке с координатами (X, Y) в 24-битном буфере Dst шириной Width
// процедура не производит проверку возможного выхода точки за пределы области буфера!
procedure SetPixel(Dst: Pointer; X, Y: LongInt; Color: LongWord; Width: LongWord); stdcall;
asm
mov eax, Y
mul Width
add eax, X
lea eax, [eax * 2 + eax]
add eax, Dst
mov edx, color
mov [eax], dl
mov [eax + 1], dh
shr edx, 8
mov [eax + 2], dh
end;
// заполняет (3 * Count) байт памяти Dst 3-ёх байтовым значением Value
// используется для закраски 24-битного буфера указанным цветом RGB(потому и 3 байта)
procedure MemoryFill3Byte(Dst: Pointer; Count, Value: LongWord); stdcall;
asm
mov ecx, Count
jecxz @exit
push edi
mov eax, Value
mov edi, Dst
dec ecx
jz @last
@next: // at first fill (count-1) pieces
stosd
dec edi
loop @next
@last: // and finally fill the last one
stosw
shr eax, 16
mov [edi], al
pop edi
@exit:
end;
procedure QueryPerf;
var
Diff: LongWord;
asm
call GetTickCount
sub eax, FrameStart
mov Diff, eax
fild Diff
fild Freq
fdivrp
fstp Instant
call GetTickCount
mov FrameStart, eax
end;
procedure Waiting;
asm
fld MaxFrameRate
fld Instant
fcomip st(0), st(1)
fstp st(0)
jna @maybe_dec
inc SleepTime
jmp @sleep
@maybe_dec:
fld MinFrameRate
fld Instant
fcomip st(0), st(1)
fstp st(0)
jnc @sleep
cmp SleepTime, 0
jz @sleep
dec SleepTime
@sleep:
push SleepTime
call Sleep
end;
function Sin(Value: Extended): Extended;
asm
FLD Value
FSIN
end;
function Cos(Value: Extended): Extended;
asm
FLD Value
FCOS
end;
function Round(Value: Extended): Int64;
asm
FLD Value
SUB ESP, 8
FISTP qword ptr [ESP]
POP EAX
POP EDX
end;
(* H = [0..360]; S = [0..255]; V = [0..255] *)
function HSV2RGB(H, S, V: LongWord): LongWord;
const
D: LongWord = 255 * 60;
var
F, VS: LongWord;
begin
with RGBQuad(Result) Do
begin
if S = 0 then
begin
Red := V;
Green := V;
Blue := V;
end
else
begin
if H = 360 then H := 0;
F := H mod 60;
H := H div 60;
VS := V * S;
case H of
0:
begin
Red := V;
Green := V - (VS * (60 - F)) div D;
Blue := V - VS div 255;
end;
1:
begin
Red := V - (VS * F) div D;
Green := V;
Blue := V - VS div 255;
end;
2:
begin
Red := V - VS div 255;
Green := V;
Blue := V - (VS * (60 - F)) div D;
end;
3:
begin
Red := V - VS div 255;
Green := V - (VS * F) div D;
Blue := V;
end;
4:
begin
Red := V - (VS * (60 - F)) div D;
Green := V - VS div 255;
Blue := V;
end;
5:
begin
Red := V;
Green := V - VS div 255;
Blue := V - (VS * F) div D;
end;
end;
end;
end;
end;
Const
PIECE_COUNT = 17;
PIECE_MULTIPLIER = 0.375;
ARC_COUNT = 12;
var
Angle: Double = PI;
bAngle: Double = 0.0;
mAngle: Double = 0.0;
sAngle: Double = 0.0;
dA: Double = PI * 2 / ARC_COUNT;
X: LongInt;
Y: LongInt;
R: Double;
procedure DrawFilledCircle(CX, CY, R, FillColor: LongInt);
var
X, Y: LongInt;
begin
with ImageBuffer do
for Y := -R to R do
for X := -R to R do
if X * X + Y * Y - R * R <= 0 then
SetPixel(Buffer, CX + X, CY + Y, FillColor, Width)
else
if X * X + Y * Y - R * R <= R then
SetPixel(Buffer, CX + X, CY + Y, (FillColor shr 1) and $007F7F7F, Width);
end;
procedure Circle(FillColor, X, Y, R: LongInt);
begin
DrawFilledCircle(X + R, Y - R, R, FillColor);
end;
procedure CircleChain(x0, y0: LongInt; Angle, dA, dR: Double);
var
X, Y, i: LongInt;
begin
for i := 1 to PIECE_COUNT do
begin
X := Round(Cos(Angle) * (R / dR) + x0);
Y := Round(Sin(Angle) * (R / dR) + y0);
Angle := Angle + dA;
Circle(HSV2RGB(LongWord(Round(Sqrt(Sqr(X - ImageBuffer.Width / 2) + Sqr(Y - ImageBuffer.Height / 2)))) mod 360, 255, 255), X, Y, Round(i * PIECE_MULTIPLIER));
end;
end;
procedure Drawing;
var
i: LongInt;
begin
with ImageBuffer do
begin
if Width < Height then
R := Width
else
R := Height;
R := R * 1.075;
sAngle := sAngle + PI * 2 / 32;
mAngle := mAngle + PI * 2 / 48;
bAngle := bAngle + PI * 2 / 64;
for i := 1 to ARC_COUNT do
begin
Angle := Angle + dA;
sAngle := sAngle + dA;
X := Round(Cos(Angle) * (R / 4.347826) + Width / 2);
Y := Round(Sin(Angle) * (R / 4.347826) + Height / 2);
CircleChain(X, Y, sAngle, PI / 15, 10.0);
end;
for i := 1 to ARC_COUNT do
begin
Angle := Angle + dA;
mAngle := mAngle + dA;
X := Round(Cos(Angle + PI / 16) * (R / 4.255319) + Width / 2);
Y := Round(Sin(Angle + PI / 16) * (R / 4.255319) + Height / 2);
CircleChain(X, Y, mAngle, PI / 18, 6.666666);
end;
for i := 1 to ARC_COUNT do
begin
Angle := Angle + dA;
bAngle := bAngle + dA;
X := Round(Cos(Angle + PI / 8) * (R / 4.166666) + Width / 2);
Y := Round(Sin(Angle + PI / 8) * (R / 4.166666) + Height / 2);
CircleChain(X, Y, bAngle, PI / 21, 5.0);
end;
end;
with ImageBuffer do
begin
DrawImage(Buffer^, Left, Top, Width, Height); // выводим на экран
MemoryFill3Byte(Buffer, Width * Height, BACK_COLOR); // закрашиваем буфер цветом фона
end;
end;
procedure DrawCircles;
begin
QueryPerf;
Drawing;
Waiting;
end;
procedure On_Redraw;
begin
BeginDraw;
DrawWindow(0, 0, WndWidth, WndHeight, nil, 0, WS_NO_DRAW, CAPTION_NONMOVABLE);
EndDraw;
end;
begin
HeapInit;
with GetScreenSize do
begin
WndWidth := Width;
WndHeight := Height;
end;
with ImageBuffer do
begin
Width := WndWidth;
Height := WndHeight;
Buffer := HeapAllocate(Width * Height * 3); // создаём буфер
MemoryFill3Byte(Buffer, Width * Height, BACK_COLOR); // закрашиваем буфер цветом фона(вообще-то он у нас в этом примере чёрный(BACK_COLOR = 0), можно не закрашивать, потому что изначально там и так нули должны быть)
end;
FrameStart := GetTickCount - 1;
SetEventMask(EM_REDRAW + EM_KEY);
while True do
case CheckEvent of
REDRAW_EVENT:
On_Redraw;
KEY_EVENT:
Break;
else
DrawCircles;
end;
end.Прикладываю уже готовые приложения Buf2dMovingColoredCircles.kex и MovingColoredCircles.kex.
Post's attachments
Buf2dMovingColoredCircles.kex 1.85 Кб, 61 скачиваний с 2021-12-28
circles.gif 1.28 Мб, 35 скачиваний с 2021-12-28
MovingColoredCircles.kex 1.63 Кб, 65 скачиваний с 2021-12-28