Программа для отображения вращающиеся спирали на экране с разрешением 320x200x256 MCGA.
Архимедова спираль — спираль, плоская кривая, траектория точки M, которая равномерно движется вдоль некоторого луча с началом в O, в то время как сам луч равномерно вращается вокруг O. Другими словами, расстояние ρ = OM пропорционально углу поворота φ луча. Повороту луча на один и тот же угол соответствует одно и то же приращение ρ.
Уравнение Архимедовой спирали в полярной системе координат записывается так:
ρ = kFi
где k — смещение точки M по лучу r, при повороте на угол равный одному радиану.
Повороту прямой на 2π соответствует смещение a = |BM| = |MA| = 2kπ. Число a — называется шагом спирали.
При раскручивании спирали, расстояние от точки O до точки M стремится к бесконечности, при этом шаг спирали остаётся постоянным (конечным), то есть, чем дальше от центра, тем ближе витки спирали, по форме, приближаются к окружности.
Program Spiral;
{$A+,B-,D+,E+,F-,G+,I+,L+,N+,O-,P-,Q-,R-,S+,T-,V-,X+,Y+}
Uses Crt,dos;
Type
RGB = Array[1..3] of Byte;
TPalette = Array[0..255] of RGB;
const
MaxX = 319; { Размеры экрана }
MaxY = 199;
MidX = MaxX div 2;
MidY = MaxY div 2;
var
MyPal, InitPal: TPalette;
TimesRun: LongInt;
i, j: registers;
Time: Longint Absolute $0000:$046c;
StartTime, EndTime: Longint;
{ Ожидает VGAшную вертикальную ретрасировку. }
procedure WaitVRetrace; Assembler;
Asm
mov dx, 3DAh
@@1:
in al, dx
and al, 08h
jnz @@1
@@2:
in al, dx
and al, 08h
jz @@2
end;
{ Определяет окончательную палитру. }
procedure SetPal(var Palet: TPalette); Assembler;
Asm
call WaitVRetrace
push ds
lds si, Palet
mov dx, 3c8h
mov al, 0
out dx, al
inc dx
mov cx, 768
rep outsb
pop ds
end;
{ Переключает экран на режим 320x200x256 MCGA}
procedure SetMCGAMode;
var
Palet: TPalette;
begin
Asm
mov ax, 0013h
int 10h
end;
FillChar(Palet, 768, 0); { Полагает все цвета палитры черными. }
SetPal(Palet);
end;
{ Переключает экран на текстовый режим }
procedure SetTextMode; Assembler;
Asm
mov ax, $0003
int 10h
end;
{ Ставит пиксель в режиме 320x200x256. }
procedure PutPixel(x, y: Word; Color: Byte); Assembler;
Asm
mov ax, y
mov bx, x
xchg ah, al
add bx, ax
shr ax, 2
add bx, ax
mov ax, $A000
mov es, ax
mov al, Color
mov es:[bx], al
end;
{ Циклически обрабатывает все цвета в палитре. }
procedure CyclePalettes;
var
ColMin: RGB;
i, j, k: registers;
begin
ColMin := MyPal[1];
for i.ax := 1 to 254 do MyPal[i.ax] := MyPal[i.ax+1];
MyPal[255] := ColMin;
ColMin := InitPal[1];
for i.ax := 1 to 254 do InitPal[i.ax] := InitPal[i.ax+1];
InitPal[255] := ColMin;
SetPal(MyPal);
end;
{ Рисует спираль на экране. }
procedure DrawSpiral(Phi0: Double; Colour: Byte);
var
x, y, i: registers;
Phase1, Phase2: Double;
begin
Phase1 := Phi0;
Phase2 := 0;
for i.ax := 0 to 1850 do
begin
x.cx := MidX + round(Phase2*sin(Phase1));
y.dx := MidY + round(Phase2*cos(Phase1)/1.2);
if (x.cx >= 0) and (x.cx <= MaxX) and (y.dx >= 0) and (y.dx <= MaxY) then PutPixel(x.cx, y.dx, Colour);
Phase1 := Phase1 + 0.0035*Pi;
Phase2 := Phase2 + 0.035*Pi;
end;
end;
begin
SetMCGAMode;
MyPal := Palette;
InitPal := Palette;
StartTime := Time;
for i.ax := 0 to 255 do { Рисует спираль в 255 различных цветах. }
DrawSpiral(i.ax*2*Pi/255, i.ax);
EndTime := Time;
TimesRun := 0;
Repeat
if (TimesRun < 256) then { Начинает поворот цветов с верху вних. }
begin
for i.ax := 0 to 255 do
for j.ax := 1 to 3 do
MyPal[i.ax,j.ax] := round(InitPal[i.ax,j.ax]*TimesRun/255);
end;
if (TimesRun > 3000-256) then
begin
for i.ax := 0 to 255 do
for j.ax := 1 to 3 do
MyPal[i.ax,j.ax] := round(InitPal[i.ax,j.ax]*(3000-TimesRun)/255);
end;
CyclePalettes;
Inc(TimesRun);
Until KeyPressed or (TimesRun > 3000);
SetTextMode;
end.
Ключевые слова:
Архимедова спираль
