old/PAS/SNOW.PAS

{$D+,E+,G+,N+,X+,Y+}
                (*)        Simple SnowFall        (*)
Program SnowFall;
Uses Dos,MGUnit;
Const BackGrndColor = 0;
      LightSnow = 255;
      DarkSnow = 254;
Type tScreen        = Array [0..63999] Of Byte;
     pScreen        = ^tScreen;
     vP=array[0..255,0..2] of byte;
Var
     PCX_File:File of char;
     Manufacturer:byte;
     Version:shortint;
     encoding:shortint;
     x,y,
     width,height,
     horz_res,vert_res:word;
     vScreen:pScreen;
     vPal:^vP;
     gd,gm:integer;
     Mmemory:Pointer;
(*) FOR PCX (*)
     i,c            : Word;
     vScr,SB        : pScreen;
     h,m,s,s1,hn,mn,sn,s1n:word;
     DF             : Boolean;
     Cnt            : Byte;
     frames:word; sec:double;
(*) *------------------* Procedure And Functions *-----------------------* (*)
Procedure Read_Header;
var c:char; ex:boolean;
begin
ex:=true;
Read(PCX_File,c);
Manufacturer:=ord(c);
if Manufacturer<>10 then begin
                         write('Error: wrong file.');
                         Ex:=False;
                         end;
Read(PCX_File,c);
version:=ord(c);
case version of
     0:writeln('Ver. 2.5 PaintBrush');
     2:writeln('Ver. 2.8 Pallette');
     3:writeln('Ver. 2.8 Without Pallette');
     5:writeln('Ver. 3.0 or greater');
     else begin
          writeln('Wrong version.');
          ex:=false;
          end;
     end;
read(PCX_File,c);
encoding:=ord(c);
if encoding=1 then writeln('RLE Encoding') else begin
                                                writeln('Wrong encoding');
                                                Ex:=false;
                                                end;
read(PCX_File,c);
x:=ord(c);
read(PCX_File,c);
y:=ord(c);
writeln('The coordinates of the upper left corner is (',x,';',y,').');
read(PCX_File,c);
width:=ord(c);
read(PCX_File,c);
height:=ord(c);
writeln('Image Height Is ',height,' and width ',width,'.');
read(PCX_File,c);
horz_res:=ord(c);
read(PCX_File,c);
vert_res:=ord(c);
writeln('Vertical rezolution is ',vert_res,' and horizontal is ',horz_res,'.');
end;

Procedure Read_Main;
var count,num,color,n:word; c:char;
begin
seek(PCX_File,128);
count:=0;
While (count<=64000) do
      begin
      Read(PCX_File,c);
      n:=ord(c);
      if (n>=192) and (N<=255) then begin
                                    num:=n-192;
                                    read(PCX_File,c);
                                    color:=ord(c);
                                    for n:=0 to num-1 do
                                        vScreen^[count+n]:=color;
                                    inc(count,num);
                                    end
      else begin vScreen^[count]:=n; inc(count); end;
end;
end;
Procedure Pal_Read;
var count:word;c:char;
begin
seek(PCX_File,FileSize(PCX_File)-256*3);
count:=0;
while (count<256) do
      begin
      Read(PCX_File,c);
      vPal^[count,0]:=ord(c) shr 2;
      Read(PCX_File,c);
      vPal^[count,1]:=ord(c) shr 2;
      Read(PCX_File,c);
      vPal^[count,2]:=ord(c) shr 2;
      inc(count);
      end;
end;

Function CalcTime(a,b,c,d,a1,b1,c1,d1:word):double;
var dh,dm,ds,ds1:integer;
begin
dh:=a1-a; dm:=b1-b; ds:=c1-c; ds1:=d1-d;
if ds1<0 then begin
              inc(ds1,60);
              dec(ds);
              end;
if ds<0 then  begin
              inc(ds,60);
              dec(dm);
              end;
if dm<0 then  begin
              inc(dm,60);
              dec(dh);
              end;
CalcTime:=((dh*60+dm)*60+ds)+(ds1/60);
end;


                (*)        Set Needed Mode        (*)
Procedure SetMode(Mode : Byte); Assembler;
asm
Mov  AH,0
Mov  AL,[Mode]
Int  10h
end;
   (*) Sets Red, Green and Blue Components Of The Current Color (*)
Procedure SetRGB(C, R, G, B : Byte); Assembler;
asm
Mov  DX, 3C8h
Mov  AL, [C]
Out  DX, AL
Inc  DX
Mov  AL, [R]
Out  DX, AL
Mov  AL, [G]
Out  DX, AL
Mov  AL, [B]
Out  DX, AL
end;
             (*)  Clears The Screen In VGA 320x200x256   (*)
Procedure Cls(Color : Byte); Assembler;
Asm
Push DS
Push $A000
Pop  ES
Mov  AL, [Color]
Mov  AH, AL
Mov  CX, 64000/2
Rep  StoSw
Pop  DS
End;
                (*) Approximates The Number For Pallete (*)
Function Color(I : Byte; Seed : Word) : Byte;
Begin
Color := Round(63*Abs(Sin(I*Pi/Seed)))
End;
                (*)   Copies The Buffer To The Screen   (*)
Procedure Flip; Assembler;
Asm
Push DS
Les  DI, vScr
Mov  DS, SEGA000
Xor  SI, SI
Mov  AX, 0A000h
Mov  ES, AX
Xor  DI, DI
Mov  CX, 16000
Db   $66
Rep  MovSw
Pop  DS
End;
                (*) Wait For The Vertical RetRace (*)
Procedure WaitRetRace;
Begin
While Port[$3da] And $08 = 0 Do
end;
                (*) Main Procedure Of Falling Snow (*)
Procedure Fall1;
Var C,
    D  : Integer;
    l,r,
    dl,
    dn,
    dr : Boolean;
Begin
For I := 63999-320 DownTo 0 Do
    Begin
      If (vScr^[I]>0) Then
            Begin
            c:=vScr^[i]; vScr^[i]:=0;
            dl:=vScr^[i+319]=0; dn:=vScr^[i+320]=0; dr:=vScr^[i+321]=0;
            if not dl and not dn and not dr then
               d:=0
            else
            if dl and dn and dr then
               begin
                 d:=random(4);
                 case d of
                      0: d:=319;
                      1: d:=320;
                      2: d:=321;
                      3: d:=1;
                      4: d:=-1;
                 end;
               end
            else
            if dl and dn and not dr then
               begin
                 d:=random(3);
                 case d of
                      0: d:=319;
                      1: d:=320;
                      2: d:=1;
                      3: d:=-1;
                 end;
               end
            else
            if dl and not dn and dr then
               begin
                 d:=random(3);
                 case d of
                      0: d:=319;
                      1: d:=321;
                      2: d:=1;
                      3: d:=-1;
                 end;
               end
            else
            if not dl and dn and dr then
               begin
                 d:=random(3);
                 case d of
                      0: d:=320;
                      1: d:=321;
                      2: d:=1;
                      3: d:=-1;
                 end;
               end
            else
            if dl and not dn and not dr then
               d:=319
            else
            if not dl and not dn and dr then
               d:=321
            else
            if not dl and dn and not dr then
               d:=320;
            {if (ParamCount<2) or ((ParamCount=1) and (ParamStr(1)='ACID'))
then}

>  Вот от сюда закоментарить

               if (vScr^[i+d]>0) and (vScr^[i+d]<250) then begin vScr^[i]:=c;
continue; end;

> и до сюда.

            case c of
                 DarkSnow : if DF then
                               if (d=0) or (i+d>63999-320) then
vScr^[i]:=LightSnow else vScr^[i+d]:=c
                            else vScr^[i]:=c;
                 LightSnow: if d=0 then vScr^[i]:=LightSnow else vScr^[i+d]:=c
             else vScr^[i]:=c;
            end;
            end;
    End
End;

Procedure ShowPicture;
var i:Word;
begin
for i:=0 to 64000 do
    If vScreen^[i]>0 then vScr^[i]:=vScreen^[i];
end;

(*) *-------------------------* Main Body *------------------------------* (*)

Begin
new(vScreen); FillChar(vScreen^,64000,0); new(vPal); FillChar(vPal^,256*3,0);
assign(PCX_File,'hny1.pcx');
reset(PCX_File); Read_Main; Pal_Read; Close(PCX_File);
SetMode($13);
for i:=0 to 255 do SetRGB(i,vPal^[i,0],vPal^[i,1],vPal^[i,2]);
Dispose(vPal);
                (*)     Prepares The Buffer     (*)
New(vScr); FillChar(vScr^,64000,0); SegA000 := Seg(vScr^);
Randomize; Cls(BackGrndColor);
                (*)       Prepares Pallete      (*)
SetRGB(254,Color(110,512),Color(110,512),Color(110,512));
SetRGB(255,Color(195,512),Color(195,512),Color(195,512));
ShowPicture;
GetTime(h,m,s,s1); frames:=0;
                (*)         Main Falling        (*)
cnt:=0;
Repeat
DF:=False;
if cnt=0 then
   inc(cnt)
else
    begin
    Df:=True;
    Cnt:=0;
    end;
                (*)      Puts Leading Flakes    (*)
For I := 0 To 319 Do
    Begin
    C := Random(170);
    Case c Of
         1: vScr^[I] := LightSnow;
         2: vScr^[I] := DarkSnow;
    End
    End;
Fall1; Flip; inc(frames);
Until Port[$60] = 1;
GetTime(hn,mn,sn,s1n);sec:=CalcTime(h,m,s,s1,hn,mn,sn,s1n);
    (*)  ShutDown The Buffer And Returns Back To The Text Screen  (*)
Dispose(vScr);Dispose(vScreen);SetMode($3);
writeln(frames/sec:2:5,' fps');
               (*)             GodBye           (*)
Writeln('Coded By Mike Korablin Jr. (MMK)',#10#13,
        'Fido   : 2:5025/2000.7@FidoNet.Org  AKA
2:5025/40.48@FidoNet.Org'#10#13,
        'E-Mail : mmk@archiv.vrn.ru');
               (*)            The End :'''(     (*)
End.