uses graph,crt;
procedure Fig(x,y,c1,c2,c3:integer);
begin
{тонкая линия}
setlinestyle(0,0,1);
{рисуем основной купол}
setcolor(c1);
line(x,y,x,y-29);
line(x,y,x+110,y);
line(x+110,y,x+110,y-29);
arc(x+55,y+135,71,108,174);
setfillstyle(1,c1);
floodfill(x+10,y-15,c1);
{рисуем нижние дуги}
setcolor(c2);
setfillstyle(1,c2);
arc(x+15,y+10,0,180,17);
arc(x+15,y+20,25,155,20);
floodfill(x+15,y-2,c2);{красим выше линии осн. купола}
floodfill(x+2,y+2,c2);{ниже слева}
floodfill(x+28,y+2,c2);{ниже справа}
arc(x+55,y+10,0,180,17);
arc(x+55,y+20,25,155,20);
floodfill(x+55,y-2,c2);
floodfill(x+42,y+2,c2);
floodfill(x+68,y+2,c2);
arc(x+95,y+10,0,180,17);
arc(x+95,y+20,25,155,20);
floodfill(x+95,y-2,c2);
floodfill(x+82,y+2,c2);
floodfill(x+108,y+2,c2);
{рисуем вертикальные дуги}
arc(x+70,y-19,270,120,20);
arc(x+60,y-16,310,90,20);
floodfill(x+85,y-16,c2);
arc(x+40,y-19,60,270,20);
arc(x+50,y-16,82,250,20);
floodfill(x+25,y-16,c2);
{рисуем стропы}
setcolor(c3);
line(x+30,y+2,x+55,y+75);
line(x,y+2,x+45,y+80);
line(x+78,y+2,x+60,y+75);
line(x+108,y+2,x+70,y+80);
{рисуем парашютиста}
setfillstyle(1,c3);
fillellipse(x+57,y+72,6,3); {голова}
fillellipse(x+57,y+85,4,10);{тело}
{руки}
bar(x+40,y+80,x+57,y+82);
bar(x+57,y+80,x+74,y+82);
bar(x+40,y+77,x+42,y+80);
bar(x+72,y+77,x+74,y+80);
line(x+39,y+77,x+43,y+77);
line(x+39,y+77,x+41,y+74);
line(x+41,y+74,x+43,y+77);
floodfill(x+41,y+75,c3);
line(x+71,y+77,x+74,y+77);
line(x+71,y+77,x+73,y+74);
line(x+73,y+74,x+75,y+77);
floodfill(x+73,y+75,c3);
setlinestyle(0,0,3);{ноги}
line(x+55,y+94,x+50,y+100);
line(x+57,y+94,x+52,y+100);
line(x+58,y+94,x+63,y+100);
line(x+60,y+94,x+65,y+100);
end;
var x,y,r,d:integer;
k:char;
begin
x:=0;
initgraph(x,y,'');
x:=getmaxX div 2-55;
y:=getmaxY div 2-35;
setbkcolor(15);{белый фон}
setcolor(12);{красным пояснения}
outtextXY(x-50,20,'Upravlenie - Strelki');
outtextXY(x-20,40,'Exit - Esc');
Fig(x,y,13,9,8);{стартовая фигура в центре}
repeat{бесконечный цикл пока не нажмем Esc}
if keypressed then{если нажата клавиша}
begin
k:=readkey;{читаем ее код}
if k=#80 then{стрелка вниз}
begin
delay(100);{задержка для просмотра}
Fig(x,y,0,0,0);{рисуем цветом фона=стираем}
if y>getmaxY-110 then d:=0{если нижний край, не двигаемся вниз}
else d:=10;{иначе вниз на 10 пикселей}
y:=y+d;
Fig(x,y,13,9,8);{рисуем в цвете}
end;
if k=#72 then{так же вверх}
begin
delay(100);
Fig(x,y,0,0,0);
if y<40 then d:=0
else d:=10;
y:=y-d;
Fig(x,y,13,9,8);
end;
if k=#77 then{вправо}
begin
delay(100);
Fig(x,y,0,0,0);
if x>getmaxX-118 then d:=0
else d:=10;
x:=x+d;
Fig(x,y,13,9,8);
end;
if k=#75 then{влево}
begin
delay(100);
Fig(x,y,0,0,0);
if x<10 then d:=0
else d:=10;
x:=x-d;
Fig(x,y,13,9,8);
end;
if k=#27 then exit;{Esc выход из программы}
end;
until k=#27;
end.
Puporev http://www.cyberforum.ru
Вращение пятиконечной звезды вокруг своего центра
Пятиконечная звезда. Анимация Паскаль
uses crt,graph; var i,x0,y0,R,gd,gm:integer; p:array[1..11]of Pointtype; a,c1,c2:integer; procedure Move(r,a,c:integer); var i,u:integer; begin u:=a; for i:=1 to 10 do begin if i mod 2=0 then begin p[i].x:=x0+round(r*cos(u*pi/180)); p[i].y:=y0-round(r*sin(u*pi/180)); end else begin p[i].x:=x0+round((r div 2)*cos(u*pi/180)); p[i].y:=y0-round((r div 2)*sin(u*pi/180)); end; u:=u+36; end; p[11].x:=p[1].x; p[11].y:=p[1].y; MoveTo(p[1].x,p[1].y); setcolor(c); for i:=1 to 11 do LineTo(p[i].x,p[i].y); {если раскомментировать следующие 2 строки звезда будет закрашенной, но сильное мерцание} {setfillstyle(1,c); floodfill(x0-1,y0,c);} end; begin R:=100; InitGraph(gd,gm,''); x0:=GetMaxX div 2; y0:=GetMaxY div 2; a:=-18; i:=1; c2:=0; repeat c1:=i; Move(r,a,c1); delay(100); Move(r,a,c2); a:=a+2; if a mod 18=0 then i:=i+1; if i=16 then i:=1; until keypressed; readln end.
http://www.cyberforum.ru
Вращение четырехугольника по окружности
uses crt,graph;
{вращение точки вокруг центра}
procedure Vrash(a:real;var x,y:integer;x0,y0,d:integer);
begin
x:=x0+round(d*cos(a));
y:=y0-round(d*sin(a));
end;
var gd,gm:integer;
ch:char;
x0,y0,w,h,d,a1x,a1y,a2x,a2y,a3x,a3y,a4x,a4y,a5x,a5y,a6x,a6y,k:integer;
u,a1,a2,a3,a4:real;
begin
clrscr;
repeat
write('Dlina (20-400) w=');
readln(w);
until (w>=20)and(w<=400);
repeat
write('Shirina (20-400) h=');
readln(h);
until (h>=20)and(h<=400);
d:=round(sqrt(sqr(w/2)+sqr(h/2)));{радиус вращения}
u:=arctan(h/w);
a1:=u; a2:=pi-u; a3:=pi+u; a4:=2*pi-u;{начальные углы вершины}
writeln('Press Enter...');
readln;
gd:=0;
initgraph(gd,gm,'');
x0:=getmaxX div 2;y0:=getmaxY div 2;{центр экрана}
outtextXY(x0-35,30,'Vyhod - any key...');
{координаты вершин}
a1x:=x0+round(d*cos(a1));a1y:=y0-round(d*sin(a1));
a2x:=x0+round(d*cos(a2));a2y:=y0-round(d*sin(a2));
a3x:=x0+round(d*cos(a3));a3y:=y0-round(d*sin(a3));
a4x:=x0+round(d*cos(a4));a4y:=y0-round(d*sin(a4));
{рисуем стартовое изображение}
Setcolor(14);
line(a1x,a1y,a2x,a2y);
line(a2x,a2y,a3x,a3y);
line(a3x,a3y,a4x,a4y);
line(a1x,a1y,a4x,a4y);
repeat
delay(20); {задержка 20 млс}
setcolor(0); {цвет фона, стираем изображение}
line(a1x,a1y,a2x,a2y);
line(a2x,a2y,a3x,a3y);
line(a3x,a3y,a4x,a4y);
line(a1x,a1y,a4x,a4y);
Vrash(a1,a1x,a1y,x0,y0,d);
Vrash(a2,a2x,a2y,x0,y0,d);
Vrash(a3,a3x,a3y,x0,y0,d);
Vrash(a4,a4x,a4y,x0,y0,d);
Setcolor(14); {выбранный цвет - рисуем}
line(a1x,a1y,a2x,a2y);
line(a2x,a2y,a3x,a3y);
line(a3x,a3y,a4x,a4y);
line(a1x,a1y,a4x,a4y);
a1:=a1+0.01;a2:=a2+0.01;a3:=a3+0.01;a4:=a4+0.01;
until keypressed;
end.
Smile :D http://www.cyberforum.ru/
{вращение точки вокруг центра}
procedure Vrash(a:real;var x,y:integer;x0,y0,d:integer);
begin
x:=x0+round(d*cos(a));
y:=y0-round(d*sin(a));
end;
var gd,gm:integer;
ch:char;
x0,y0,w,h,d,a1x,a1y,a2x,a2y,a3x,a3y,a4x,a4y,a5x,a5y,a6x,a6y,k:integer;
u,a1,a2,a3,a4:real;
begin
clrscr;
repeat
write('Dlina (20-400) w=');
readln(w);
until (w>=20)and(w<=400);
repeat
write('Shirina (20-400) h=');
readln(h);
until (h>=20)and(h<=400);
d:=round(sqrt(sqr(w/2)+sqr(h/2)));{радиус вращения}
u:=arctan(h/w);
a1:=u; a2:=pi-u; a3:=pi+u; a4:=2*pi-u;{начальные углы вершины}
writeln('Press Enter...');
readln;
gd:=0;
initgraph(gd,gm,'');
x0:=getmaxX div 2;y0:=getmaxY div 2;{центр экрана}
outtextXY(x0-35,30,'Vyhod - any key...');
{координаты вершин}
a1x:=x0+round(d*cos(a1));a1y:=y0-round(d*sin(a1));
a2x:=x0+round(d*cos(a2));a2y:=y0-round(d*sin(a2));
a3x:=x0+round(d*cos(a3));a3y:=y0-round(d*sin(a3));
a4x:=x0+round(d*cos(a4));a4y:=y0-round(d*sin(a4));
{рисуем стартовое изображение}
Setcolor(14);
line(a1x,a1y,a2x,a2y);
line(a2x,a2y,a3x,a3y);
line(a3x,a3y,a4x,a4y);
line(a1x,a1y,a4x,a4y);
repeat
delay(20); {задержка 20 млс}
setcolor(0); {цвет фона, стираем изображение}
line(a1x,a1y,a2x,a2y);
line(a2x,a2y,a3x,a3y);
line(a3x,a3y,a4x,a4y);
line(a1x,a1y,a4x,a4y);
Vrash(a1,a1x,a1y,x0,y0,d);
Vrash(a2,a2x,a2y,x0,y0,d);
Vrash(a3,a3x,a3y,x0,y0,d);
Vrash(a4,a4x,a4y,x0,y0,d);
Setcolor(14); {выбранный цвет - рисуем}
line(a1x,a1y,a2x,a2y);
line(a2x,a2y,a3x,a3y);
line(a3x,a3y,a4x,a4y);
line(a1x,a1y,a4x,a4y);
a1:=a1+0.01;a2:=a2+0.01;a3:=a3+0.01;a4:=a4+0.01;
until keypressed;
end.
Smile :D http://www.cyberforum.ru/
Пламя 3
ИСПОЛЬЗОВАНЫ АССЕМБЛЕРНЫЕ ВСТАВКИ
{$A+,B-,D+,E+,F-,G+,I-,L+,N+,O-,P+,Q-,R-,S-,T-,V-,X+,Y+}
{$M 16384,0,655360}
{
Hi guys, try this, use it in your code, but please credit
Frank Jan Sorensen Alias:Frank Patxi (fjs@lab.jt.dk) for the
fireroutine.
}
{
Hi again, guys!
If you use this code, please also credit me, Joachim Fenkes, 'cause I added
the following speedups:
-Replaced one tiny loop with a faster Move(...) (not much speedup)
-Wrote the main display loop in 100% assembler, including a faster random
number generator (the RNG is only a more or less optimized version of
Borland's generator (see MEGARAND.ASM), but with the advantage of the
ultimate crash if you call it normally :-)
-Changed version number into 1.10 (this isn't a speedup, but necessary :-)
}
{
Bcoz of the knowledge that reading from videocards is much slower than
writing to them, I changed some things to write and read from/to a pointer
and put the result with 32-Bit moves to the screen
Also I added now a much more faster randommer.
The result of this change is more than 3 times fast than before
Stefan Goehler
Please credit me!
...
to JF: your bug is fixed!
}
Program Burn;
uses
Dos,Crt;
Const
RootRand = 20; { Max/Min decrease of the root of the flames }
Decay = 5; { How far should the flames go up on the screen? }
{ This MUST be positive - JF }
MinY = 50; { Startingline of the flame routine.
(should be adjusted along with MinY above) }
Smooth = 1; { How descrete can the flames be?}
MinFire = 50; { limit between the "starting to burn" and
the "is burning" routines }
XStart = 90; { Startingpos on the screen, should be divideable by 4 without remain!}
XEnd = 210; { Guess! }
Width = XEnd-XStart; {Well- }
MaxColor = 110; { Constant for the MakePal procedure }
FireIncrease : Byte = 3; {3 = Wood, 90 = Gazolin}
{Var
Scr : Array[0..199,0..319] Of Byte Absolute $A000:$0000;}
Type
ColorValue = record
R, G, B : byte;
end;
VGAPaletteType = array[0..255] of ColorValue;
function fastrand : word;assembler;
const
factor : longint = $8088405;
asm
db 66h,81h,0E3h,0FFh,0FFh,00h,00h{and ebx,$FFFF}
db 66h;mov ax,word ptr randseed
db 66h;mul word ptr factor
db 66h;inc ax
db 66h;mov word ptr randseed,ax
db 66h;shr ax,16
db 66h;mul bx
db 66h;shr ax,16
end;
procedure ReadPal(var Pal);
var
K : VGAPaletteType Absolute Pal;
Regs : Registers;
begin
with Regs do
begin
AX := $1017;
BX := 0;
CX := 256;
ES := Seg(K);
DX := Ofs(K);
Repeat Until Port[$03DA] And $08 = $08; {Wait for rescan}
Intr($10,Regs);
end;
end;
procedure move(var input,output;size : word);assembler;
{
implemented by me -SG
-you can use this routine instead of the one implemented in Pascal...
it's much more faster (nearly 4 times depending on your pc)!
}
asm
mov dx,ds
lds si,input
les di,output
mov cx,size
mov ax,cx
shr cx,2
jz @not4
db 0F3h,66h,0A5h{rep movsd}
@not4:
mov cx,ax
and cx,11b
jz @end
rep movsb
@end:
mov ds,dx
end;
procedure WritePal(var Pal);
Var
K : VGAPaletteType Absolute Pal;
Regs : Registers;
begin
with Regs do
begin
AX := $1012;
BX := 0;
CX := 256;
ES := Seg(K);
DX := Ofs(K);
Repeat Until Port[$03DA] And $08 = $08; {Wait for rescan}
Intr($10,Regs);
end;
end;
Procedure Hsi2Rgb(H, S, I : Real; var C : ColorValue);
{Convert (Hue, Saturation, Intensity) -> (RGB)}
var
T : Real;
Rv, Gv, Bv : Real;
begin
T := H;
Rv := 1 + S * Sin(T - 2 * Pi / 3);
Gv := 1 + S * Sin(T);
Bv := 1 + S * Sin(T + 2 * Pi / 3);
T := 63.999 * I / 2;
with C do
begin
R := trunc(Rv * T);
G := trunc(Gv * T);
B := trunc(Bv * T);
end;
end; { Hsi2Rgb }
{ Faster put'n get pixel routines! }
(*
procedure put(x,y : integer; c : byte); assembler;
{ Written by Matt Sottile }
asm
mov ax,y
shl ax,6
mov di,ax
shl di,2
add di,ax
add di,x
mov ax,0a000h
mov es,ax
mov al,c
mov es:[di],al
end;
Function get(x,y : integer):byte; assembler;
{ Put Modified by me }
asm
mov ax,y
shl ax,6
mov di,ax
shl di,2
add di,ax
add di,x
mov ax,0a000h
mov es,ax
mov al,es:[bx]
end;
*)
Procedure MakePal;
Var
I : Byte;
Pal : VGAPaletteType;
begin
FillChar(Pal,SizeOf(Pal),0);
For I:=1 To MaxColor Do
HSI2RGB(4.6-1.5*I/MaxColor,I/MaxColor,I/MaxColor,Pal[I]);
For I:=MaxColor To 255 Do
begin
Pal[I]:=Pal[I-1];
With Pal[I] Do
begin
If R<63 Then Inc(R);
If R<63 Then Inc(R);
If (I Mod 2=0) And (G<53) Then Inc(G);
If (I Mod 2=0) And (B<63) Then Inc(B);
end;
end;
WritePal(Pal);
end;
Function Rand(R:Integer):Integer;{ Return a random number between -R And R}
begin
Rand:=Random(R*2+1)-R;
end;
Procedure Help;
Var
Mode : Byte;
R : Registers;
begin
R.Ax:=$0F00;
Intr($10,R);
Mode:=R.Al;
R.Ax:=$0003; {TextMode}
Intr($10,R);
ClrScr;
WriteLn('Burn version 1.15');
WriteLn;
WriteLn('Light''n''play');
WriteLn;
WriteLn('Keys : ');
WriteLn('<space> : Throw in a match');
WriteLn('<W> : Water');
WriteLn('<+> : Increase intensity');
WriteLn('<-> : Decrease intensity');
WriteLn('<C> : Initialize fire');
WriteLn('<1>..<9>: Burnability (1=Wood, 9=Gaz)');
WriteLn('<?> : This help');
WriteLn;
Write('Hit any key kid >');
ReadKey;
R.Ax:=$0000+Mode;
Intr($10,R);
If Mode = $13 Then MakePal;
end;
Var
FlameArray : Array[XStart..XEnd] Of Byte;
LastMode : Byte;
I,J : Integer;
X,P : Integer;
MoreFire,
V : Integer;
R : Registers;
Ch : Char;
pt : pointer;
begin
getmem(pt,64000);
Help;
RandomIze;
R.Ax:=$0F00;
Intr($10,R);
LastMode:=R.Al;
R.Ax:=$0013;
Intr($10,R);
MoreFire:=1;
MakePal;
(* Use this if you want to view the palette *)
{ For I:=0 To 255 Do
For J:=0 To 20 Do
Put(I,J,I);
ReadKey;}
{ Initialize FlameArray }
For I:=XStart To XEnd Do
FlameArray[I]:=0;
{ FillChar(Scr,SizeOf(Scr),0); { Clear Screen }
fillchar(pt^,64000,0);
repeat
If KeyPressed Then Ch:=ReadKey Else Ch:='.'; {'.' = Nothing (Dummy)}
While KeyPressed Do ReadKey; { Empty Keyboard buffer }
{ Put the values from FlameArray on the bottom line of the screen }
Move(FlameArray,ptr(seg(pt^),ofs(pt^)+199*320+pred(XStart))^, Width+1);
{ This loop makes the actual flames }
{ Here comes my assembler code - JF }
{ There's still a little bug in the code: When you have started the fire,
some pixels near the upper left corner of the screen dance around. }
asm
les DI, PT
mov SI, DI
mov AX, MinY*320+XStart
add SI, MinY*320+XStart
add DI, MinY*320+XStart-320
mov CX, 200-MinY
@@1:
push CX
mov CX, Width+1
@@2:
mov AL,ES:[SI]
inc SI
cmp AL, Decay
jb @@3
cmp CX, 2
jb @@3
cmp CX, Width-1
ja @@3
push CX
push AX
mov BX, 3
call FastRand
dec AX
push AX
mov BX, Decay
call FastRand
pop DX
pop CX
sub CL, AL
mov AL, CL
sub DI, DX
mov ES:[DI],AL{a little bit faster than stosb}
inc DI
add DI, DX
pop CX
dec CX
jnz @@2
add SI, 319-Width
mov DI, SI
sub DI, 320
pop CX
dec CX
jnz @@1
jmp @@4
@@3: xor AL, AL
mov ES:[DI],AL
inc DI
dec CX
jnz @@2
add SI, 319-Width
mov DI, SI
sub DI, 320
pop CX
dec CX
jnz @@1
@@4:
end;
{
(* This was the original code I translated to assembler - JF *)
For I:=XStart To XEnd Do
For J:=MinY To 199 Do
begin
V:=VMem[J, I];
If (V=0) Or
(V<Decay) Or
(I<=XStart) Or
(I>=XEnd) Then
Put(I, Pred(J), 0);
else
Put(I-Pred(Random(3)), Pred(J), V-Random(Decay));
end;
}
{Match?}
If (Random(150)=0) Or (Ch=' ') Then
FillChar(FlameArray[XStart+Random(XEnd-XStart-5)],5,255);
{In-/Decrease?}
If (Ch='-') Then If MoreFire >-2 Then Dec(MoreFire);
If (Ch='+') Then If MoreFire < 4 Then Inc(MoreFire);
{!!}
If UpCase(Ch) = 'C' Then FillChar(FlameArray,SizeOf(FlameArray),0);
If UpCase(Ch) = 'W' Then
for I:=1 To 10 Do FlameArray[XStart+Random(Width)]:=0;
If Ch = '?' Then Help;
if Ch in ['1'..'9'] Then FireIncrease:=3+Sqr(Ord(Ch)-Ord('1'));
{This loop controls the "root" of the
flames ie. the values in FlameArray.}
For I:=XStart To XEnd Do
begin
X:=FlameArray[I];
If X<MinFire Then { Increase by the "burnability"}
begin
{Starting to burn:}
If X>10 Then Inc(X,Random(FireIncrease));
end
else
{ Otherwise randomize and increase by intensity (is burning)}
Inc(X,Rand(RootRand)+MoreFire);
If X>255 Then X:=255; { X Too large ?}
FlameArray[I]:=X;
end;
{ Pour a little water on both sides of
the fire to make it look nice on the sides}
For I:=1 To Width Div 8 Do
begin
X:=Trunc(Sqr(Random)*Width/8);
FlameArray[XStart+X]:=0;
FlameArray[XEnd-X]:=0;
end;
{Smoothen the values of FrameArray to avoid "descrete" flames}
P:=0;
For I:=XStart+Smooth To XEnd-Smooth Do
begin
X:=0;
For J:=-Smooth To Smooth Do Inc(X,FlameArray[I+J]);
FlameArray[I]:=X Div succ(Smooth shl 1);
end;
for i := miny to 199 do
move(ptr(seg(pt^),ofs(pt^)+i*320+xstart)^,ptr(segA000,i*320+xstart)^,width+1);
Until Ch=#27;
{Restore video mode}
textmode(lastmode);
{Good bye}
freemem(pt,64000);
end.
http://ishodniki.ru
Пламя 2
ИСПОЛЬЗУЮТСЯ ВСТАВКИ АССЕМБЛЕР
{ --- Fire by Patrick Van Oosterwijck - XorBit - Fido 2:292/120.91 --- }
{$G+}
program XorBitFire;
uses crt;
const verttweak=6; { Tweak constant : number of vertical }
{ scanlines for 1 pixel (>=3) }
xsize=320; { X size of the fire }
ysize=400 div verttweak; { Y size of the fire }
invlines=3; { Number of invisible lines }
const firepal: array[0..767] of byte = (
0, 0, 0, 1, 0, 0, 1, 0, 0, 3, 0, 0, 4, 0,
0, 5, 0, 0, 7, 0, 0, 8, 0, 0, 9, 0, 0, 10,
0, 0, 12, 0, 0, 13, 0, 0, 14, 0, 0, 16, 0, 0,
17, 0, 0, 18, 0, 0, 20, 0, 0, 21, 0, 0, 22, 0,
0, 23, 0, 0, 25, 0, 0, 26, 0, 0, 27, 0, 0, 29,
0, 0, 30, 0, 0, 31, 0, 0, 32, 0, 0, 34, 0, 0,
35, 0, 0, 36, 0, 0, 38, 0, 0, 39, 0, 0, 40, 0,
0, 41, 0, 0, 43, 0, 0, 44, 0, 0, 45, 0, 0, 47,
0, 0, 47, 0, 0, 47, 0, 0, 47, 1, 0, 47, 1, 0,
47, 1, 0, 47, 2, 0, 47, 2, 0, 48, 3, 0, 48, 3,
0, 48, 4, 0, 48, 4, 1, 48, 5, 1, 48, 5, 1, 48,
6, 1, 48, 6, 1, 49, 7, 1, 49, 7, 1, 49, 8, 1,
49, 8, 1, 49, 9, 1, 49, 9, 2, 49, 10, 2, 49, 10,
2, 50, 11, 2, 50, 11, 2, 50, 12, 2, 50, 12, 2, 50,
13, 3, 50, 13, 3, 50, 14, 3, 50, 14, 3, 51, 15, 3,
51, 15, 3, 51, 16, 4, 51, 16, 4, 51, 17, 4, 51, 17,
4, 51, 18, 4, 51, 19, 4, 52, 19, 4, 52, 19, 5, 52,
20, 5, 52, 20, 5, 52, 21, 5, 52, 22, 5, 52, 22, 6,
52, 23, 6, 53, 23, 6, 53, 23, 6, 53, 24, 6, 53, 24,
6, 53, 25, 7, 53, 26, 7, 53, 26, 7, 53, 27, 7, 54,
27, 7, 54, 28, 7, 54, 28, 7, 54, 29, 8, 54, 29, 8,
54, 30, 8, 54, 30, 8, 54, 31, 8, 55, 31, 8, 55, 32,
9, 55, 32, 9, 55, 33, 9, 55, 33, 9, 55, 34, 9, 55,
34, 10, 55, 35, 10, 55, 35, 10, 56, 36, 10, 56, 36, 10,
56, 37, 10, 56, 37, 11, 56, 38, 11, 56, 38, 11, 56, 39,
11, 56, 39, 11, 57, 40, 12, 57, 40, 12, 57, 41, 12, 57,
41, 12, 57, 42, 12, 57, 42, 13, 57, 43, 13, 57, 43, 13,
58, 44, 13, 58, 44, 13, 58, 45, 13, 58, 45, 14, 58, 46,
14, 58, 46, 14, 58, 46, 14, 58, 47, 14, 59, 47, 15, 59,
48, 15, 59, 48, 15, 59, 49, 15, 59, 49, 15, 59, 50, 16,
59, 50, 16, 59, 51, 16, 60, 51, 16, 60, 52, 16, 60, 52,
17, 60, 53, 17, 60, 53, 17, 60, 54, 17, 60, 54, 18, 60,
55, 18, 61, 55, 18, 61, 55, 18, 61, 56, 18, 61, 56, 19,
61, 57, 19, 61, 57, 19, 61, 58, 19, 61, 58, 19, 62, 59,
20, 62, 59, 20, 62, 60, 20, 62, 60, 20, 62, 60, 20, 62,
61, 21, 62, 61, 21, 62, 62, 21, 63, 62, 21, 63, 63, 22,
63, 63, 22, 63, 63, 23, 63, 63, 23, 63, 63, 23, 63, 63,
24, 63, 63, 24, 63, 63, 25, 63, 63, 25, 63, 63, 26, 63,
63, 26, 63, 63, 27, 63, 63, 27, 63, 63, 28, 63, 63, 28,
63, 63, 29, 63, 63, 29, 63, 63, 29, 63, 63, 30, 63, 63,
30, 63, 63, 31, 63, 63, 31, 63, 63, 32, 63, 63, 32, 63,
63, 33, 63, 63, 33, 63, 63, 34, 63, 63, 34, 63, 63, 35,
63, 63, 35, 63, 63, 36, 63, 63, 36, 63, 63, 36, 63, 63,
37, 63, 63, 37, 63, 63, 38, 63, 63, 38, 63, 63, 39, 63,
63, 39, 63, 63, 40, 63, 63, 40, 63, 63, 41, 63, 63, 41,
63, 63, 42, 63, 63, 42, 63, 63, 42, 63, 63, 43, 63, 63,
43, 63, 63, 44, 63, 63, 44, 63, 63, 45, 63, 63, 45, 63,
63, 46, 63, 63, 46, 63, 63, 47, 63, 63, 47, 63, 63, 48,
63, 63, 48, 63, 63, 48, 63, 63, 49, 63, 63, 49, 63, 63,
50, 63, 63, 50, 63, 63, 51, 63, 63, 51, 63, 63, 52, 63,
63, 52, 63, 63, 53, 63, 63, 53, 63, 63, 54, 63, 63, 54,
63, 63, 55, 63, 63, 55, 63, 63, 55, 63, 63, 56, 63, 63,
56, 63, 63, 57, 63, 63, 57, 63, 63, 58, 63, 63, 58, 63,
63, 59, 63, 63, 59, 63, 63, 60, 63, 63, 60, 63, 63, 61,
63, 63, 61, 63, 63, 61, 63, 63, 62, 63, 63, 63);
type scrtype=array[0..ysize+invlines-1, 0..xsize-1] of byte;
var screen: scrtype absolute $A000:0;
virtscr: scrtype;
i, firepower: integer;
key: char;
procedure CalculateFire(var source, dest);assembler;
asm
PUSH DS
CLD
LDS SI, source
LES DI, dest
ADD SI, xsize
MOV CX, xsize*(ysize+invlines-1)
@@1: XOR AX,AX
XOR BX,BX
MOV AL,[SI-xsize]
MOV BL,[SI-1]
ADD AX,BX
MOV BL,[SI+1]
ADD AX,BX
MOV BL,[SI]
ADD AX,BX
SHR AX,2
JZ @@2
DEC AL
@@2: STOSB
INC SI
DEC CX
JNZ @@1
POP DS
end;
procedure WaitRetrace;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);assembler;
asm
PUSH DS
LDS SI,palet
MOV CX,768
XOR AL,AL
MOV DX,3C8h
OUT DX,AL
INC DX
REP OUTSB
POP DS
end;
procedure SetGraphMode;assembler;
asm
MOV AX,13h
INT 10h
MOV DX,03d4h
MOV AX,4009h+((verttweak-1)*100h)
OUT DX,AX
end;
procedure SetTextMode;assembler;
asm
MOV AX,3h
INT 10h
end;
procedure Move32(var source,dest;count:word);assembler;
asm
MOV DX,DS
CLD
LDS SI,source
LES DI,dest
MOV CX,count
MOV BL,CL
AND BL,3
SHR CX,2
DB 66h
REP MOVSW
MOV CL,BL
REP MOVSB
MOV DS,DX
end;
begin
writeln;
writeln(' Fire by Patrick Van Oosterwijck - XorBit - Fido 2:292/120.91');
writeln(' Keys : ''+'' = Burn fire to Hell');
writeln(' ''-'' = Extinguish fire');
writeln(' ESC = Escape to a safer place');
writeln(' -> Press any key to burn...');
while readkey=#0 do;
SetGraphMode;
SetPal(firepal);
Randomize;
firepower:=18;
repeat
key:=#0;
while keypressed do key:=readkey;
if (key='+') and (firepower<50) then inc(firepower);
if (key='-') and (firepower>0) then dec(firepower);
for i:=0 to xsize-1 do
if random(50)<=firepower then
virtscr[ysize+invlines-1,i]:=random(100)+156
else
virtscr[ysize+invlines-1,i]:=0;
CalculateFire(virtscr,virtscr);
WaitRetrace;
Move32(virtscr,screen,xsize*ysize);
until key=#27;
SetTextMode;
writeln(' You have survived it, lucky one...');
end.
That's all folks...
Bye, Patrick. - XorBit -
--- The-Box Point 0.15- PC
* Origin: 95... 95... 95... Aaaaarrggghhh!!!!!! (2:292/120.91)
http://ishodniki.ru
Развивающийся флаг
program sinmap;
uses crt;
const
gseg : word = $a000;
spd = 1; size = 3; curve = 125;
xmax = 230 div size;
ymax = 140 div size;
sofs = 30; samp = 10; slen = 255;
var stab : array[0..slen] of word;
procedure csin; var i : byte; begin
for I := 0 to slen do stab[i] := round(sin(i*4*pi/slen)*samp)+sofs; end;
procedure displaymap;
type scrarray = array[0..xmax,0..ymax] of byte;
var
postab : array[0..xmax,0..ymax] of word;
bitmap : scrarray;
x,y,xp,yp,sidx : word;
begin
fillchar(bitmap,sizeof(bitmap),0);
sidx := 0;
for x := 0 to xmax do
for y := 0 to (ymax div 3) do bitmap[x,y] := lightred;
for x := 0 to xmax do
for y := (ymax div 3) to 2*(ymax div 3) do bitmap[x,y] := white;
for x := 0 to xmax do
for y := 2*(ymax div 3) to ymax do bitmap[x,y] := lightblue;
repeat
while (port[$3da] and 8) <> 0 do;
while (port[$3da] and 8) = 0 do;
for x := 0 to xmax do
for y := ymax downto 0 do begin
mem[gseg:postab[x,y]] := 0;
xp := size*x+stab[(sidx+curve*x+curve*y) mod slen];
yp := size*y+stab[(sidx+4*x+curve*y+y) mod slen];
postab[x,y] := xp+yp*320;
mem[gseg:postab[x,y]] := bitmap[x,y];
end;
sidx := (sidx+spd) mod slen;
until keypressed;
end;
begin
csin;
asm mov ax,13h; int 10h; end;
displaymap;
textmode(lastmode);
end.
http://ishodniki.ru/
Плазма
ИСПОЛЬЗОВАНЫ ВСТАВКИ АССЕМБЛЕР
{ From : Marcin Borkowski 2:480/25 03.02.95}
{ Subj : **Plasma Code**}
{$A+,B-,D+,E+,F-,G+,I-,L+,N-,O-,P-,Q-,R-,S-,T-,V+,X+,Y+}
{$M 16384,0,655360}
uses crt;
var
i : integer;
licznik : byte;
paleta : array[0..767]of byte;
screen : array[0..63999]of byte absolute $A000:0;
{ This is necessaery for drawing plasma. Don't mind. It is the same piece of
code I use in voxel space code posted here for several times, not necessarilly
by me. }
function ncol(mc,n,dvd : integer): integer;
var
loc : integer;
begin
loc:=(mc+n-random(2*n)) div dvd;
ncol:=loc;
if loc>250 then ncol:=250;
if loc<5 then ncol:=5
end;
procedure plasma(x1,y1,x2,y2 : word);
var
xn,yn,dxy,p1,p2,p3,p4 : word;
begin
if (x2-x1<2) and (y2-y1<2) then EXIT;
p1:=screen[320*y1+x1];
p2:=screen[320*y2+x1];
p3:=screen[320*y1+x2];
p4:=screen[320*y2+x2];
xn:=(x2+x1) shr 1;
yn:=(y2+y1) shr 1;
dxy:=5*(x2-x1+y2-y1) div 3;
if screen[320*y1+xn]=0 then screen[320*y1+xn]:=ncol(p1+p3,dxy,2);
if screen[320*yn+x1]=0 then screen[320*yn+x1]:=ncol(p1+p2,dxy,2);
if screen[320*yn+x2]=0 then screen[320*yn+x2]:=ncol(p3+p4,dxy,2);
if screen[320*y2+xn]=0 then screen[320*y2+xn]:=ncol(p2+p4,dxy,2);
screen[320*yn+xn]:=ncol(p1+p2+p3+p4,dxy,4);
plasma(x1,y1,xn,yn);
plasma(xn,y1,x2,yn);
plasma(x1,yn,xn,y2);
plasma(xn,yn,x2,y2)
end;
begin
asm
mov ax,13h
int 10h
end;
{ Generating palette RGBs }
for i:=1 to 170 do paleta[3*i]:=round(63*sin(i/170*pi));
for i:=1 to 170 do paleta[3*i+256]:=round(63*sin(i/170*pi));
for i:=1 to 170 do paleta[(3*i+512) mod 768]:=round(63*sin(i/170*pi));
plasma(1,1,319,199);
{ Licznik - it means 'counter' in Polish. }
licznik:=0;
repeat
{ Wait for retrace. }
repeat until (port[$03DA] and 8)=0;
repeat until (port[$03DA] and 8)=8;
{ Changing palette - we start with color number licznik }
port[$3C8]:=licznik;
{ Three outsb are copying whole RGB to VGA register. After those three
instructions value in port $3C8 is incremented. Here I'm redefining whole
palette, but there is no problem in changing only one color. }
asm
mov si,offset paleta
mov cx,768
mov dx,$3C9
rep outsb
end;
inc(licznik);
until keypressed;
asm
mov ax,3h
int 10h
end;
end.
http://ishodniki.ru/
{ From : Marcin Borkowski 2:480/25 03.02.95}
{ Subj : **Plasma Code**}
{$A+,B-,D+,E+,F-,G+,I-,L+,N-,O-,P-,Q-,R-,S-,T-,V+,X+,Y+}
{$M 16384,0,655360}
uses crt;
var
i : integer;
licznik : byte;
paleta : array[0..767]of byte;
screen : array[0..63999]of byte absolute $A000:0;
{ This is necessaery for drawing plasma. Don't mind. It is the same piece of
code I use in voxel space code posted here for several times, not necessarilly
by me. }
function ncol(mc,n,dvd : integer): integer;
var
loc : integer;
begin
loc:=(mc+n-random(2*n)) div dvd;
ncol:=loc;
if loc>250 then ncol:=250;
if loc<5 then ncol:=5
end;
procedure plasma(x1,y1,x2,y2 : word);
var
xn,yn,dxy,p1,p2,p3,p4 : word;
begin
if (x2-x1<2) and (y2-y1<2) then EXIT;
p1:=screen[320*y1+x1];
p2:=screen[320*y2+x1];
p3:=screen[320*y1+x2];
p4:=screen[320*y2+x2];
xn:=(x2+x1) shr 1;
yn:=(y2+y1) shr 1;
dxy:=5*(x2-x1+y2-y1) div 3;
if screen[320*y1+xn]=0 then screen[320*y1+xn]:=ncol(p1+p3,dxy,2);
if screen[320*yn+x1]=0 then screen[320*yn+x1]:=ncol(p1+p2,dxy,2);
if screen[320*yn+x2]=0 then screen[320*yn+x2]:=ncol(p3+p4,dxy,2);
if screen[320*y2+xn]=0 then screen[320*y2+xn]:=ncol(p2+p4,dxy,2);
screen[320*yn+xn]:=ncol(p1+p2+p3+p4,dxy,4);
plasma(x1,y1,xn,yn);
plasma(xn,y1,x2,yn);
plasma(x1,yn,xn,y2);
plasma(xn,yn,x2,y2)
end;
begin
asm
mov ax,13h
int 10h
end;
{ Generating palette RGBs }
for i:=1 to 170 do paleta[3*i]:=round(63*sin(i/170*pi));
for i:=1 to 170 do paleta[3*i+256]:=round(63*sin(i/170*pi));
for i:=1 to 170 do paleta[(3*i+512) mod 768]:=round(63*sin(i/170*pi));
plasma(1,1,319,199);
{ Licznik - it means 'counter' in Polish. }
licznik:=0;
repeat
{ Wait for retrace. }
repeat until (port[$03DA] and 8)=0;
repeat until (port[$03DA] and 8)=8;
{ Changing palette - we start with color number licznik }
port[$3C8]:=licznik;
{ Three outsb are copying whole RGB to VGA register. After those three
instructions value in port $3C8 is incremented. Here I'm redefining whole
palette, but there is no problem in changing only one color. }
asm
mov si,offset paleta
mov cx,768
mov dx,$3C9
rep outsb
end;
inc(licznik);
until keypressed;
asm
mov ax,3h
int 10h
end;
end.
http://ishodniki.ru/
Пламя
ИСПОЛЬЗОВАНЫ ВСТАВКИ АСССЕМБЛЕР
{$A+,B+,D-,E-,F-,G+,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X+,Y-}
{$M 20000,0,0}
{Burn V1.0: the original fireroutine was made by
Frank Jan Sorensen alias Frank Patxi (fjs@lab.jt.dk)}
{Burn V2.0: interaction, speedup and sparks
added by Gerhard Piran}
Program Burn2; {12.12.95}
uses Dos, Crt;
var regs: Registers;
pic: integer; {drawn pictures}
{********************************************************}
procedure SetVideoMode (vMode: byte);
begin
regs.ax := vMode; {Bit 7 = 1: RAM nicht l”schen}
Intr ($10,regs);
end;
{--------------------------------------------------------}
function GetVideoMode: byte;
begin
regs.ah := $0F;
intr ($10, regs);
GetVideoMode := regs.al;
end;
{*********************************************************}
type ColorValue = record R,G,B: byte; end;
VGAPaletteType = array[0..255] of ColorValue;
procedure ReadPal (var pal: VGAPaletteType);
begin
regs.AX := $1017;
regs.BX := 0;
regs.CX := 256;
regs.ES := Seg(pal);
regs.DX := Ofs(pal);
repeat until Port[$03DA] And $08 = $08; {Wait for rescan}
Intr ($10,regs);
end;
{--------------------------------------------------------}
procedure WritePal (var pal: VGAPaletteType);
begin
regs.AX := $1012;
regs.BX := 0;
regs.CX := 256;
regs.ES := Seg(pal);
regs.DX := Ofs(pal);
repeat until Port[$03DA] and $08 = $08; {Wait for rescan}
Intr($10,regs);
end;
{*********************************************************}
{ Convert HSI (Hue, Saturation, Intensity) -> RGB }
{---------------------------------------------------------}
procedure Hsi2Rgb (H, S, I: Real; var C: ColorValue);
var T, Rv, Gv, Bv: Real;
begin
T := H;
Rv := 1 + S * Sin(T - 2 * Pi / 3);
Gv := 1 + S * Sin(T);
Bv := 1 + S * Sin(T + 2 * Pi / 3);
T := 63.999 * I / 2;
c.R := trunc(Rv * T);
c.G := trunc(Gv * T);
c.B := trunc(Bv * T);
end;
{*********************************************************}
{ fast pixel drawing for graphic mode 320x200x256
{---------------------------------------------------------}
procedure PutPixel (x,y: integer; c: byte); assembler;
asm
mov ax,y
mov bx,ax
shl ax,8
shl bx,6
add bx,ax
add bx,x
mov ax,0a000h
mov es,ax
mov al,c
mov es:[bx],al
end;
{--------------------------------------------------------}
function GetPixel (x,y: integer): byte;
begin
asm
mov ax,y
mov bx,ax
shl ax,8
shl bx,6
add bx,ax
add bx,x
mov ax,0a000h
mov es,ax
mov al,es:[bx]
mov @result,al
end;
end;
{********************************************************}
procedure Info;
begin
ClrScr;
WriteLn('Burn V 2.0, a hot burning stuff'#13#10);
WriteLn('commands: '#13#10
+' ? this help'#13#10
+' + - change width'#13#10
+' C clear base fire'#13#10
+' W give water into fire'#13#10
+' P draw palette'#13#10
+' A animate values on/off');
WriteLn(' space random values'#13#10
+' cursor edit values'#13#10
+' ESC exit demo'#13#10);
WriteLn('values 1: decrease root of flame'#13#10
+' 2: how far flames go up'#13#10
+' 3: more or less fire'#13#10
+' 4: smooth root of flame'#13#10
+' 5: limit of start burning'#13#10
+' 6: burnability (wood..gaz)'#13#10
+' 7: sparks'#13#10
+' 8: new flames'#13#10
+' 9: put water into fire'#13#10);
end;
{********************************************************}
const maxPar = 9;
actPar: integer = 1;
procedure StartBurning (xl,yl: integer);
type tPar = record min, max, value: integer end;
const par: array [1..maxPar] of tPar
=((min: 0; max: 50; value: 10) {0: rootRand}
,(min: 0; max: 50; value: 15) {1: decay}
,(min: -2; max: 10; value: 10) {2: moreFire}
,(min: 0; max: 9; value: 10) {3: smooth}
,(min: 0; max:100; value: 10) {4: minFire}
,(min: 3; max: 90; value: 10) {5: fireInc}
,(min: 0; max: 10; value: 10) {6: sparks}
,(min: 0; max: 20; value: 10) {7: new fire}
,(min: 0; max: 20; value: 10)); {8: put water}
const maxX = 319;
maxY = 199;
bkColor = 16;
var vga256: array[0..maxY,0..maxX] of byte absolute $A000:0;
cb: char;
rootRand, {Max/Min decrease of the root of the flames}
moreFire, {change fire intensity}
decay, {How far should the flames go up on the screen ?}
smooth, {How descrete can the flames be?}
minFire, {limit between the "starting to burn" and
the "is burning" routines }
fireIncrease, {3 = Wood, 90 = Gazolin}
sparks, {new sparks per picture}
newFlame, {create new flame}
putWater: integer;{put water to fire}
x1,x2,y1,y2: integer; {drawing rectangle}
{********************************************************}
procedure MakePal;
const maxColor = 110;
var ni: integer; pal: VGAPaletteType;
begin
FillChar (pal, SizeOf (pal), 0);
for ni := 1 to MaxColor
do HSI2RGB (4.6-1.5*ni/MaxColor, ni/MaxColor, ni/MaxColor, pal[ni]);
for ni := MaxColor to 255
do begin
pal[ni] := pal[ni-1];
With pal[ni] do
begin
if R < 63 then Inc(R);
if R < 63 then Inc(R);
if (ni Mod 2=0) And (G<53) then Inc(G);
if (ni Mod 2=0) And (B<63) then Inc(B);
end;
end;
WritePal (pal);
end;
procedure DrawPaletteScreen;
var xi, yi: integer;
begin
MakePal;
for yi := 0 to maxY
do for xi := 0 to maxX do PutPixel (xi,yi,yi);
end;
procedure DrawValues;
var ni, yi: integer;
begin
for ni := 1 to maxPar
do begin
yi := succ(ni) * 3;
FillChar (vga256[yi,100], 120, 0);
with par[ni]
do if actPar = ni
then FillChar (vga256[yi,100], 1 + longint(value)*119 div 20, 100)
else FillChar (vga256[yi,100], 1 + longint(value)*119 div 20, 50);
end;
end;
procedure CalcValues;
begin
with par[1] do rootRand := min + value * (max - min) div 20;
with par[2] do decay := max - value * (max - min) div 20;
with par[3] do moreFire := min + value * (max - min) div 20;
with par[4] do smooth := min + value * (max - min) div 20;
with par[5] do minFire := min + value * (max - min) div 20;
with par[6] do fireIncrease := min + sqr (value);
with par[7] do sparks := min + value * (max - min) div 20;
with par[8] do newFlame := max - value * (max - min) div 20;
with par[9] do putWater := max - value * (max - min) div 20;
end;
procedure ChangeValue;
begin
cb := ReadKey;
if cb = 'P' {down} then actPar := (actPar mod maxPar) + 1;
if cb = 'H' {up} then actPar := (actPar+maxPar-2) mod maxPar + 1;
with par[actPar]
do begin
if cb = 'K' {left} then if value > 0 then dec (value);
if cb = 'M' {right} then if value < 20 then inc (value);
end;
CalcValues;
DrawValues;
cb := #1;
end;
procedure RandomValues;
var ni: integer;
begin
for ni := 1 to maxPar
do par[ni].value := random(21);
CalcValues;
DrawValues;
end;
procedure AnimateValues;
var ni: integer;
begin
ni := 1 + random (maxPar);
with par[ni]
do if random (2) = 0
then if value < 20 then inc (value) else
else if value > 0 then dec (value);
CalcValues;
DrawValues;
end;
procedure ChangeSize (dx: integer);
var yi: integer;
begin
if (dx > 0) and (x1 - dx > 2)
then repeat
dec (x1);
inc (x2);
dec (dx);
for yi := y1 to y2
do begin
PutPixel (x1,yi,0);
PutPixel (x2,yi,0);
end;
until dx = 0;
if (dx < 0) and (x1 - dx < 140)
then repeat
for yi := y1 to y2
do begin
PutPixel (x1, yi, bkColor);
PutPixel (x2, yi, bkColor);
end;
inc (x1);
dec (x2);
inc (dx);
until dx = 0;
xl := x2 - x1 - 1;
end;
procedure Help;
begin
SetVideoMode (3); {TextMode}
ClrScr;
Info;
Write ('Hit any key to start ');
cb := ReadKey;
SetVideoMode ($13);
MakePal;
end;
const animValues: boolean = false;
var flameArray: array[0..319] of byte;
x,xi,y,c,v: integer;
begin
x1 := (320 - xl) div 2; x2 := x1 + xl - 1;
y1 := (200 - yl) div 2; y2 := y1 + yl - 1;
Help;
Randomize;
FillChar (vga256, SizeOf(vga256), bkColor);
FillChar (flameArray, SizeOf(flameArray), 0);
for x := x1 to x2 do for y := y1 to y2 do PutPixel (x,y,0);
CalcValues;
pic := 0;
repeat
inc (pic);
if KeyPressed then cb := upcase(ReadKey) else cb := #1;
if cb = #0 then ChangeValue;
while KeyPressed do ReadKey; {empty keyboard buffer}
{Put the values from flameArray on the bottom line of the screen}
for x := x1 to x2 do PutPixel (x, y2, flameArray[x]);
{This loop makes the actual flames}
for xi := x1 to x2
do begin
if xi = x1 then x := xi
else if xi < x2 then x := xi - 1
else x := xi - 2;
for y := y1 + 1 to y2
do begin
v := GetPixel (xi,y);
if (v = 0)
or (v < decay)
{ then PutPixel (x,pred(y),0)
else PutPixel (x-pred(Random(3)),Pred(y),v-Random(decay));
} then vga256[pred(y),xi] := 0
else vga256[pred(y),x+Random(3)] := v-Random(decay);
end;
end;
for xi := 1 to sparks
do begin
x := x1 + random (xl);
y := y2 - random (yl - 10);
PutPixel (x,y, GetPixel (x,y)+y);
end;
if Random(newFlame) = 0 {new fire ?}
then FillChar (flameArray[x1+Random(xl-5)],5,199);
if Random(putWater)= 0 {put water ?}
then FillChar (flameArray[x1+Random(xl-5)],3,0);
if cb <> #1 {check input ?}
then begin
if cb = '+' then ChangeSize (+5)
else if cb = '-' then ChangeSize (-5)
else if cb = 'R' then RandomValues
else if cb = ' ' then RandomValues
else if cb = 'A' then animValues := not animValues
else if cb = 'C' then FillChar (flameArray, SizeOf(flameArray),0)
else if cb = 'W' then for x := 1 to xl div 10
do flameArray[x1+Random(xl)] := 0
else if cb = '?' then Help
else if cb = 'P' then DrawPaletteScreen;
end;
if animValues then AnimateValues;
{This loop controls the "root" of the flames (values in flameArray)}
for x := x1 to x2 do
begin
c := flameArray[x];
if c < MinFire then {Increase by the "burnability"}
begin {Starting to burn:}
if c > 10 then Inc (c, Random (fireIncrease));
end
else {Otherwise randomize and increase by intensity (is burning)}
Inc (c, Random (rootRand * 2 + 1) - rootRand + moreFire);
if c > 200 then c := 200; {c too large ?}
flameArray[x] := c;
end;
{Pour a little water on both sides of the fire
to make it look nice on the sides}
for x := 1 to xl div 8 do
begin
c := Trunc(Sqr(Random)*xl/8);
flameArray[x1+c] := 0;
flameArray[x2-c] := 0;
end;
{Smoothen the values of FrameArray to avoid "descrete" flames}
for x := x1+Smooth to x2-Smooth do
begin
c := 0;
for y := -Smooth to Smooth do Inc (c,flameArray[x+y]);
flameArray[x] := c div (2*Smooth+1);
end;
until (cb = #27);
end;
{********************************************************}
var lastMode: byte;
Begin
lastMode := GetVideoMode; {save video mode}
StartBurning (120, 100); {fire simulation}
SetVideoMode (lastMode); {Restore video mode}
Info;
End.
http://ishodniki.ru/
Падающий снег
ИСПОЛЬЗОВАНЫ АССЕМБЛЕРНЫЕ ВСТАВКИ
{$A+,B-,D-,E-,F-,G+,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X+,Y-}
{$M 4096,0,655360}
{ tapstep = 4 }
PROGRAM Snowy;
CONST
FlakeCount = 1024;
TYPE
TFlake = RECORD
x,y: INTEGER;
Depth: BYTE;
Falling: BOOLEAN;
InAir: BOOLEAN;
END;
VAR
Screen: ARRAY[0..63999] OF BYTE ABSOLUTE $A000:0;
Flake: ARRAY[1..FlakeCount] OF TFlake;
FUNCTION Keypressed: BOOLEAN;
ASSEMBLER;
ASM
XOR BX,BX
MOV AH,01H
INT 16H
JZ @Done
MOV BX,-1
@Done:
MOV AX,BX
END;
FUNCTION Readkey: WORD;
ASSEMBLER;
ASM
XOR AH,AH
INT 16H
END;
PROCEDURE VideoModeSet(Mode: BYTE);
ASSEMBLER;
ASM
XOR AH,AH
MOV AL,[Mode]
INT 10H
END;
PROCEDURE PaletteSet(VAR PaletteBuffer; StartColour, EndColour: BYTE);
ASSEMBLER;
ASM
PUSH DS
LDS SI,[PaletteBuffer]
XOR CX,CX
MOV CL,[EndColour]
MOV AH,[StartColour]
MOV BH,AH
CLD
MOV BL,1
CMP CL,AH
JA @@Incrementing
STD
NEG BL
XCHG CL,AH
@@Incrementing:
SUB CL,AH
INC CX
CLI
@@FillLoop:
MOV DX,3C8H
MOV AL,BH
OUT DX,AL
MOV DX,3C9H
LODSB
OUT DX,AL
LODSB
OUT DX,AL
LODSB
OUT DX,AL
ADD BH,BL
LOOP @@FillLoop
STI
@@Done:
POP DS
END;
PROCEDURE TimerWait;
VAR
i: WORD;
BEGIN
i:=MEM[$40:$6C];
WHILE i=MEM[$40:$6C] DO
;
END;
PROCEDURE PixelPut(x,y: INTEGER; c: BYTE);
BEGIN
IF (x>-1) AND (x<320) AND (y>-1) AND (y<200) THEN
Screen[y*320+x]:=c;
END;
PROCEDURE GeneratePalette;
TYPE
TComponent = RECORD
r,g,b: BYTE;
END;
VAR
NewPalette: ARRAY[0..255] OF TComponent;
i: INTEGER;
BEGIN
FOR i:=0 TO 255 DO
BEGIN
NewPalette[i].r:=i DIV 4;
NewPalette[i].g:=i DIV 4;
NewPalette[i].b:=i DIV 4;
END;
PaletteSet(NewPalette,1,255);
END;
PROCEDURE InitializeSnow;
VAR
i: INTEGER;
BEGIN
FOR i:=1 TO FlakeCount DO
BEGIN
Flake[i].Falling:=FALSE;
Flake[i].InAir:=FALSE;
END;
END;
PROCEDURE ShowSnow;
VAR
i: INTEGER;
BEGIN
FOR i:=1 TO FlakeCount DO
IF Flake[i].InAir THEN
PixelPut(Flake[i].x,Flake[i].y,Flake[i].Depth*8);
END;
PROCEDURE MoveSnow;
VAR
i: INTEGER;
NewSnow: BYTE;
Spd,Loc: INTEGER;
BEGIN
NewSnow:=RANDOM(255);
FOR i:=1 TO FlakeCount DO
BEGIN
IF (NOT Flake[i].Falling) AND (NewSnow>0) THEN
BEGIN
Flake[i].y:=RANDOM(60)-70;
Flake[i].x:=RANDOM(320);
Flake[i].Falling:=TRUE;
Flake[i].InAir:=TRUE;
Flake[i].Depth:=RANDOM(32);
END
ELSE
BEGIN
Spd:=Flake[i].Depth DIV 12+1+RANDOM(2);
Flake[i].y:=Flake[i].y+Spd;
Flake[i].x:=Flake[i].x-2+RANDOM(5);
IF Flake[i].y>199 THEN
BEGIN
Flake[i].InAir:=FALSE;
Flake[i].Falling:=FALSE;
END;
END;
IF NewSnow>0 THEN
NewSnow:=NewSnow-1;
END;
END;
PROCEDURE KillSnow;
VAR
i: INTEGER;
BEGIN
FOR i:=1 TO FlakeCount DO
IF (Flake[i].Falling) AND (Flake[i].InAir) THEN
PixelPut(Flake[i].x,Flake[i].y,0);
END;
BEGIN
VideoModeSet($13); { set 320x200x256 videomode }
InitializeSnow; { initialize snowflakes }
GeneratePalette; { set suitable palette }
REPEAT
MoveSnow; { change positions of snowflakes }
ShowSnow; { show snowflakes }
TimerWait; { pause for about 1/18th seconds }
KillSnow; { remove snowflakes }
UNTIL Keypressed; { repeat, until the key was pressed }
Readkey; { flush keyboard buffer }
VideoModeSet($3); { set 80x25 textmode }
END.
http://ishodniki.ru
Сфера, состоящая из точек, вращается в трехмерном пространстве и скачет, как мячик, на экране.
ИСПОЛЬЗОВАНЫ ВСТАВКИ Ассемблер
{$g+}
program bumping_3d_sphere;
const
dots = 99;
gseg : word = $a000;
_x = 0; _y = 1; _z = 2;
spd = 2;
dist = 100;
divd = 1024;
ptab : array[0..255] of byte = (
123,121,119,117,115,114,112,110,108,106,104,103,101,99,97,96,94,92,91,
89,87,86,84,82,81,79,78,76,75,73,72,70,69,67,66,64,63,62,60,59,58,56,
55,54,52,51,50,49,48,46,45,44,43,42,41,39,38,37,36,35,34,33,32,31,30,
29,28,27,26,26,25,24,23,22,21,21,20,19,18,17,17,16,15,15,14,13,13,12,
12,11,10,10,9,9,8,8,7,7,6,6,5,5,5,4,4,4,3,3,3,2,2,2,2,1,1,1,1,1,1,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,5,5,6,6,
7,7,7,8,8,9,9,10,11,11,12,12,13,14,14,15,16,16,17,18,19,19,20,21,22,
23,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,
46,47,48,49,51,52,53,54,56,57,58,60,61,62,64,65,67,68,69,71,72,74,75,
77,78,80,82,83,85,86,88,90,91,93,95,96,98,100,102,103,105,107,109,111,
113,114,116,118,120,122,124,126);
type
prec = record x,y,z : integer; end;
ppos = array[0..dots] of prec;
styp = array[0..255] of integer;
var
stab : styp;
dot : ppos;
procedure setpal(col,r,g,b : byte); assembler;
asm
mov dx,03c8h
mov al,col
out dx,al
inc dx
mov al,r
out dx,al
mov al,g
out dx,al
mov al,b
out dx,al
end;
procedure init;
const
ctab : array[0..99,_x.._z] of integer = (
(-18,24,2),(14,-19,19),(23,14,-13),(-1,22,-20),(-3,1,30),(-1,5,30),
(-11,-27,-4),(-1,0,-30),(-12,-11,25),(-18,-13,20),(-3,12,27),
(-27,6,-13),(-30,-1,1),(-6,-9,-28),(4,-28,11),(2,22,-20),(-5,1,-30),
(2,1,30),(-7,21,21),(-7,18,-23),(17,-22,-11),(-10,5,28),(0,-1,30),
(11,-25,-13),(-6,-28,-10),(13,12,-24),(0,0,-30),(-20,21,8),(-3,-30,-4),
(16,7,-24),(13,-4,-27),(4,-9,-28),(-10,-1,-28),(-19,-22,-8),(7,-6,29),
(-16,-22,-13),(23,6,-18),(22,-7,-19),(-5,3,-30),(-3,5,-29),(12,0,28),
(-6,13,-26),(24,-16,-8),(-7,23,18),(-10,28,-5),(21,20,8),(19,-5,23),
(0,10,-28),(23,13,-14),(4,-6,29),(19,12,20),(8,-17,-23),(17,21,13),
(-16,3,25),(-2,4,30),(-24,17,3),(-2,-1,-30),(-9,-8,27),(-10,4,-28),
(10,-19,21),(3,22,-20),(-6,1,29),(-22,-21,3),(0,-1,-30),(30,1,4),
(-29,7,-1),(-6,23,-18),(-10,-28,3),(-3,10,-28),(16,-23,-10),
(-8,23,-17),(-6,3,29),(2,-19,24),(-13,14,-23),(13,-26,9),(-17,21,-12),
(8,2,29),(16,-13,22),(9,9,27),(7,-15,25),(-25,16,-2),(-1,-3,-30),
(18,0,-24),(12,-3,27),(3,3,-30),(-22,-16,-13),(-5,-5,29),(21,-14,-16),
(3,21,21),(21,-20,-8),(27,6,12),(-13,-13,-23),(1,11,-28),(25,-14,-9),
(3,1,-30),(-2,-3,-30),(1,2,30),(8,20,21),(-20,22,6),(11,13,25));
var i : byte;
begin
for i := 0 to dots do begin
dot[i].x := ctab[i,_x];
dot[i].y := ctab[i,_y];
dot[i].z := ctab[i,_z];
end;
for i := 1 to 64 do setpal(i,10+i div 3,10+i div 2,i);
end;
procedure csin(var stab : styp); var i : byte; begin
for i := 0 to 255 do stab[i] := round(sin(2*i*pi/255)*divd); end;
function sinus(i : byte) : integer; begin
sinus := stab[i]; end;
{function sinus(i : word) : integer; assembler; asm
mov di,i; mov ax,word ptr stab[di]; end;}
function cosin(i : byte) : integer; begin
cosin := stab[(i+192) mod 255]; end;
{function cosin(i : word) : integer; assembler; asm
mov di,i; add di,192; mov ax,word ptr stab[di]; and ax,255 end;}
function esc : boolean; begin
esc := port[$60] = 1; end;
procedure bumprotate;
const
xst = spd; yst = spd; zst = -spd; xdiv : shortint = 1;
var
xp : array[0..dots] of word; { 0 -> 319 }
yp : array[0..dots] of byte; { 0 -> 199 }
objx,n : word;
x,y,z,i,j,k : integer;
pc,phix,phiy,phiz : byte;
begin
objx := 160; pc := 128; phix := 0; phiy := 0; phiz := 0;
repeat
asm
mov dx,03dah
@l1:
in al,dx
test al,8
jnz @l1
@l2:
in al,dx
test al,8
jz @l2
end; { retrace }
setpal(0,15,0,0);
for n := 0 to dots do begin
asm
mov es,gseg { put graphicssegment in es }
mov si,n { get index }
xor ah,ah { clear hi-byte }
mov al,byte ptr yp[si] { get indexed-value from yp }
cmp al,200 { check if value greater than 200 }
jae @skip { if so, then jump out }
shl si,1 { x2 for word-size }
mov bx,word ptr xp[si] { get indexed-value from xp }
cmp bx,320 { check if value greater than 320 }
jae @skip { if so, then jump out }
shl ax,6 { multiply with 64 }
mov di,ax { keep in di }
shl ax,2 { multiply with 4 }
add di,ax { add with di (64+(4*64)=320) }
add di,bx { add horizontal value }
xor al,al { al zero (black color) }
mov [es:di],al { move to screen }
@skip:
end; { check if dot in screen, if so: clear it }
i := (cosin(phiy)*dot[n].x - sinus(phiy)*dot[n].z) div divd;
j := (cosin(phiz)*dot[n].y - sinus(phiz)*i) div divd;
k := (cosin(phiz)*dot[n].z + sinus(phiy)*dot[n].x) div divd;
x := (cosin(phiz)*i + sinus(phiz)*dot[n].y) div divd;
y := (cosin(phix)*j + sinus(phix)*k) div divd;
z := (cosin(phix)*k - sinus(phix)*j) div divd;
xp[n] := objx+(-x*dist) div (z-dist);
yp[n] := 50+ptab[pc]+(-y*dist) div (z-dist);
asm
mov es,gseg; { put graphicssegment in es }
mov si,n { get index }
xor ah,ah { clear hi-byte }
mov al,byte ptr yp[si] { get indexed-value from yp }
cmp al,200 { check if value greater than 200 }
jae @skip { if so, then jump out }
shl si,1 { x2 for word-size }
mov bx,word ptr xp[si] { get indexed-value from xp }
cmp bx,320 { check if value greater than 320 }
jae @skip { if so, then jump out }
shl ax,6 { multiply with 64 }
mov di,ax { keep in di }
shl ax,2 { multiply with 4 }
add di,ax { add with di (64+(4*64)=320) }
add di,bx { add horizontal value }
mov ax,z { get z (depth) value }
shr ax,1 { divide by 2 (range/2=30) }
add ax,32 { add 32, ax is now in range 0 -> 64 }
mov [es:di],al { move to screen }
@skip:
end; { check if dot in screen, if so: set it }
end;
inc(objx,xdiv);
if (objx < 35) or (objx > 285) then xdiv := -xdiv;
inc(pc,spd);
inc(phix,xst);
inc(phiy,yst);
inc(phiz,zst);
setpal(0,0,0,0);
until esc;
end;
begin
asm mov ax,13h; int 10h; end;
init;
csin(stab);
bumprotate;
asm mov ax,3; int 10h; end;
end.
http://ishodniki.ru/
{$g+}
program bumping_3d_sphere;
const
dots = 99;
gseg : word = $a000;
_x = 0; _y = 1; _z = 2;
spd = 2;
dist = 100;
divd = 1024;
ptab : array[0..255] of byte = (
123,121,119,117,115,114,112,110,108,106,104,103,101,99,97,96,94,92,91,
89,87,86,84,82,81,79,78,76,75,73,72,70,69,67,66,64,63,62,60,59,58,56,
55,54,52,51,50,49,48,46,45,44,43,42,41,39,38,37,36,35,34,33,32,31,30,
29,28,27,26,26,25,24,23,22,21,21,20,19,18,17,17,16,15,15,14,13,13,12,
12,11,10,10,9,9,8,8,7,7,6,6,5,5,5,4,4,4,3,3,3,2,2,2,2,1,1,1,1,1,1,0,0,
0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,5,5,6,6,
7,7,7,8,8,9,9,10,11,11,12,12,13,14,14,15,16,16,17,18,19,19,20,21,22,
23,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,
46,47,48,49,51,52,53,54,56,57,58,60,61,62,64,65,67,68,69,71,72,74,75,
77,78,80,82,83,85,86,88,90,91,93,95,96,98,100,102,103,105,107,109,111,
113,114,116,118,120,122,124,126);
type
prec = record x,y,z : integer; end;
ppos = array[0..dots] of prec;
styp = array[0..255] of integer;
var
stab : styp;
dot : ppos;
procedure setpal(col,r,g,b : byte); assembler;
asm
mov dx,03c8h
mov al,col
out dx,al
inc dx
mov al,r
out dx,al
mov al,g
out dx,al
mov al,b
out dx,al
end;
procedure init;
const
ctab : array[0..99,_x.._z] of integer = (
(-18,24,2),(14,-19,19),(23,14,-13),(-1,22,-20),(-3,1,30),(-1,5,30),
(-11,-27,-4),(-1,0,-30),(-12,-11,25),(-18,-13,20),(-3,12,27),
(-27,6,-13),(-30,-1,1),(-6,-9,-28),(4,-28,11),(2,22,-20),(-5,1,-30),
(2,1,30),(-7,21,21),(-7,18,-23),(17,-22,-11),(-10,5,28),(0,-1,30),
(11,-25,-13),(-6,-28,-10),(13,12,-24),(0,0,-30),(-20,21,8),(-3,-30,-4),
(16,7,-24),(13,-4,-27),(4,-9,-28),(-10,-1,-28),(-19,-22,-8),(7,-6,29),
(-16,-22,-13),(23,6,-18),(22,-7,-19),(-5,3,-30),(-3,5,-29),(12,0,28),
(-6,13,-26),(24,-16,-8),(-7,23,18),(-10,28,-5),(21,20,8),(19,-5,23),
(0,10,-28),(23,13,-14),(4,-6,29),(19,12,20),(8,-17,-23),(17,21,13),
(-16,3,25),(-2,4,30),(-24,17,3),(-2,-1,-30),(-9,-8,27),(-10,4,-28),
(10,-19,21),(3,22,-20),(-6,1,29),(-22,-21,3),(0,-1,-30),(30,1,4),
(-29,7,-1),(-6,23,-18),(-10,-28,3),(-3,10,-28),(16,-23,-10),
(-8,23,-17),(-6,3,29),(2,-19,24),(-13,14,-23),(13,-26,9),(-17,21,-12),
(8,2,29),(16,-13,22),(9,9,27),(7,-15,25),(-25,16,-2),(-1,-3,-30),
(18,0,-24),(12,-3,27),(3,3,-30),(-22,-16,-13),(-5,-5,29),(21,-14,-16),
(3,21,21),(21,-20,-8),(27,6,12),(-13,-13,-23),(1,11,-28),(25,-14,-9),
(3,1,-30),(-2,-3,-30),(1,2,30),(8,20,21),(-20,22,6),(11,13,25));
var i : byte;
begin
for i := 0 to dots do begin
dot[i].x := ctab[i,_x];
dot[i].y := ctab[i,_y];
dot[i].z := ctab[i,_z];
end;
for i := 1 to 64 do setpal(i,10+i div 3,10+i div 2,i);
end;
procedure csin(var stab : styp); var i : byte; begin
for i := 0 to 255 do stab[i] := round(sin(2*i*pi/255)*divd); end;
function sinus(i : byte) : integer; begin
sinus := stab[i]; end;
{function sinus(i : word) : integer; assembler; asm
mov di,i; mov ax,word ptr stab[di]; end;}
function cosin(i : byte) : integer; begin
cosin := stab[(i+192) mod 255]; end;
{function cosin(i : word) : integer; assembler; asm
mov di,i; add di,192; mov ax,word ptr stab[di]; and ax,255 end;}
function esc : boolean; begin
esc := port[$60] = 1; end;
procedure bumprotate;
const
xst = spd; yst = spd; zst = -spd; xdiv : shortint = 1;
var
xp : array[0..dots] of word; { 0 -> 319 }
yp : array[0..dots] of byte; { 0 -> 199 }
objx,n : word;
x,y,z,i,j,k : integer;
pc,phix,phiy,phiz : byte;
begin
objx := 160; pc := 128; phix := 0; phiy := 0; phiz := 0;
repeat
asm
mov dx,03dah
@l1:
in al,dx
test al,8
jnz @l1
@l2:
in al,dx
test al,8
jz @l2
end; { retrace }
setpal(0,15,0,0);
for n := 0 to dots do begin
asm
mov es,gseg { put graphicssegment in es }
mov si,n { get index }
xor ah,ah { clear hi-byte }
mov al,byte ptr yp[si] { get indexed-value from yp }
cmp al,200 { check if value greater than 200 }
jae @skip { if so, then jump out }
shl si,1 { x2 for word-size }
mov bx,word ptr xp[si] { get indexed-value from xp }
cmp bx,320 { check if value greater than 320 }
jae @skip { if so, then jump out }
shl ax,6 { multiply with 64 }
mov di,ax { keep in di }
shl ax,2 { multiply with 4 }
add di,ax { add with di (64+(4*64)=320) }
add di,bx { add horizontal value }
xor al,al { al zero (black color) }
mov [es:di],al { move to screen }
@skip:
end; { check if dot in screen, if so: clear it }
i := (cosin(phiy)*dot[n].x - sinus(phiy)*dot[n].z) div divd;
j := (cosin(phiz)*dot[n].y - sinus(phiz)*i) div divd;
k := (cosin(phiz)*dot[n].z + sinus(phiy)*dot[n].x) div divd;
x := (cosin(phiz)*i + sinus(phiz)*dot[n].y) div divd;
y := (cosin(phix)*j + sinus(phix)*k) div divd;
z := (cosin(phix)*k - sinus(phix)*j) div divd;
xp[n] := objx+(-x*dist) div (z-dist);
yp[n] := 50+ptab[pc]+(-y*dist) div (z-dist);
asm
mov es,gseg; { put graphicssegment in es }
mov si,n { get index }
xor ah,ah { clear hi-byte }
mov al,byte ptr yp[si] { get indexed-value from yp }
cmp al,200 { check if value greater than 200 }
jae @skip { if so, then jump out }
shl si,1 { x2 for word-size }
mov bx,word ptr xp[si] { get indexed-value from xp }
cmp bx,320 { check if value greater than 320 }
jae @skip { if so, then jump out }
shl ax,6 { multiply with 64 }
mov di,ax { keep in di }
shl ax,2 { multiply with 4 }
add di,ax { add with di (64+(4*64)=320) }
add di,bx { add horizontal value }
mov ax,z { get z (depth) value }
shr ax,1 { divide by 2 (range/2=30) }
add ax,32 { add 32, ax is now in range 0 -> 64 }
mov [es:di],al { move to screen }
@skip:
end; { check if dot in screen, if so: set it }
end;
inc(objx,xdiv);
if (objx < 35) or (objx > 285) then xdiv := -xdiv;
inc(pc,spd);
inc(phix,xst);
inc(phiy,yst);
inc(phiz,zst);
setpal(0,0,0,0);
until esc;
end;
begin
asm mov ax,13h; int 10h; end;
init;
csin(stab);
bumprotate;
asm mov ax,3; int 10h; end;
end.
http://ishodniki.ru/
Подписаться на:
Сообщения (Atom)