SuperHack/SuperHack CD.bin/CODING/MISC/MAG05.ZIP/TUNNEL.PAS

Pascal/Delphi Source File | 1995-11-05 | 4.0 KB | 192 lines

Program Tunnel;

Uses Crt;                       { CRT has some good general routines in it }

Const VGA=$A000;

Type RgbItem=Record
                   R,G,B:Byte;
             End;
     RgbList=Array[0..255] of RgbItem;

     Table=Array[0..1799] Of Real;
     PTable=^Table;

Var Pal1:RgbList;
    R:Word;

    Sines:Ptable;
    Cosines:Ptable;


Procedure Initgraph; Assembler;
Asm
   Mov AH,0
   Mov AL,13h
   Int 10h
End;

Procedure Closegraph; Assembler;
Asm
   Mov AH,0
   Mov AL,03h
   Int 10h
End;

Procedure WaitVBL; Assembler;
Label A1,A2;
Asm
   Mov DX,3DAh
   A1:
      In AL,DX
      And AL,08h
      Jnz A1
   A2:
      In AL,DX
      And AL,08h
      Jz A2
End;

Procedure InitTables;
Var A:Word;
    B:Real;
Begin
     Getmem(Sines,Sizeof(Sines^));
     Getmem(Cosines,Sizeof(Cosines^));
     B:=0;
     For A:=0 To 1799 Do
     Begin
          Sines^[A]:=Sin(B);
          Cosines^[A]:=Cos(B);
          B:=B+0.005;
     End;
End;

Procedure ClearTables;
Begin
     Freemem(Sines,Sizeof(Sines^));
     Freemem(Cosines,Sizeof(Cosines^));
End;

Procedure PutPixel(X,Y,C:Word);
Begin
     Mem[VGA:(Y*320)+X]:=C;
End;

Procedure GetColor(Col:Byte;Var R,G,B:Byte);
Begin
     Port[$3C7]:=Col;
     R:=Port[$3C9];
     G:=Port[$3C9];
     B:=Port[$3C9];
End;

Procedure SetColor(Col,R,B,G:Byte);
Begin
     Port[$3C8]:=Col;
     Port[$3C9]:=R;
     Port[$3C9]:=G;
     Port[$3C9]:=B;
End;

Procedure GetPalette(Var Pal:RgbList);
Var A:Byte;
Begin
     For A:=0 To 255 do GetColor(A,Pal[A].R,Pal[A].G,Pal[A].B);
End;

Procedure SetPalette(Pal:RgbList);
Var A:Byte;
Begin
     WaitVBL;
     For A:=0 To 255 do SetColor(A,Pal[A].R,Pal[A].G,Pal[A].B);
End;

Procedure SetBlack(Var Pal:RgbList);
Var A:Byte;
Begin
     For A:=0 to 255 Do
     Begin
          Pal[A].R:=0;
          Pal[A].G:=0;
          Pal[A].B:=0;
     End;
End;

Procedure Cls(Col:Byte);
Begin
     FillChar(Mem[$A000:0000],64000,Col);
End;

Procedure RotatePal(Var Pal:RgbList;First,Last:Byte);
Var Temp:RgbItem;
    A:Byte;
Begin
     Temp:=Pal[Last];
     For A:=Last-1 DownTo First Do
     Begin
          Pal[A+1]:=Pal[A];
     End;
     Pal[First]:=Temp;
End;

Procedure LoadPal(Filename:String;Var Pal:RgbList); { This loads a palette    }
Var F:File;                                         { from disk... I will     }
Begin                                               { explain it in a future  }
     Assign(F,Filename);                            { article, all about disk }
     Reset(F,1);                                    { access...               }
     Blockread(F,Ptr(Seg(Pal[0].R),Ofs(Pal[0].R))^,768);
     Close(F);
End;

Procedure Circle(X,Y,R:Integer;Col:Byte);
Var Px,Py:Integer;
    Deg:Word;
Begin
     For Deg:=0 to 1799 Do
     Begin
          Px:=Trunc(R*Sines^[Deg]+X);
          Py:=Trunc(R*Cosines^[Deg]+Y);
          PutPixel(Px,Py,Col);
     End;
End;

Procedure Circles;
Begin
     LoadPal('Tunnel.Pal',Pal1);
     SetPalette(Pal1);
     For R:=1 To 99 Do Circle(160,100,R,R*2);
     Repeat
           If Keypressed Then If Readkey=Chr(27) Then Exit;
           RotatePal(Pal1,1,255);
           SetPalette(Pal1);
     Until False;
End;

Begin
     Randomize;                       { Resets the random number generator }
     Clrscr;
     Writeln('Hello to another SpellCaster production...');
     Writeln('This one only has circles... ');
     Writeln;
     Writeln('Press ESC to exit any of the program...');
     Repeat Until Keypressed;
     Initgraph;
     InitTables;
     Circles;
     ClearTables;
     Closegraph;
     Writeln('Did you liked it ?... ');
     Writeln('I hope you did.');
     Writeln('Write to ''The Mag'':');
     Writeln('Snail Mail: Praceta Carlos Manito Torres, nº4 / 6ºC');
     Writeln('            2900 Setúbal');
     Writeln('                 Portugal');
     Writeln;
     Writeln('E-Mail: [e-mail]');
     Writeln;
     Writeln;
     Writeln;
     Repeat Until Keypressed;
End.