home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 15 / CD_ASCQ_15_070894.iso / news / 2513 / wormie.pas < prev    next >
Pascal/Delphi Source File  |  1993-08-16  |  11KB  |  307 lines
  1. {$R-}
  2. {$X+}
  3. Program T_holic;
  4.  
  5. USES
  6.    Crt;
  7.  
  8. CONST
  9.    Vga : Word = $a000;
  10.  
  11.    Block : Array[1..40,1..40] of Byte = (
  12.  
  13.        (0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0),
  14.        (0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0),
  15.        (0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0),
  16.        (0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0),
  17.        (0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0),
  18.        (0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0),
  19.        (0,0,0,0,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,0,0,0,0),
  20.        (0,0,0,1,1,1,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,1,1,1,0,0,0),
  21.        (0,0,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,0,0),
  22.        (0,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,0),
  23.        (1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1),
  24.        (1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1),
  25.        (1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1),
  26.        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),
  27.        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),
  28.        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),
  29.        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),
  30.        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),
  31.        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),
  32.        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),
  33.        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),
  34.        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),
  35.        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),
  36.        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),
  37.        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),
  38.        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),
  39.        (1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1),
  40.        (1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1),
  41.        (1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1),
  42.        (1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1),
  43.        (0,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,0),
  44.        (0,0,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,0,0),
  45.        (0,0,0,1,1,1,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,1,1,1,0,0,0),
  46.        (0,0,0,0,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,0,0,0,0),
  47.        (0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0),
  48.        (0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0),
  49.        (0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0),
  50.        (0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0),
  51.        (0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0),
  52.        (0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0)
  53.        );
  54.  
  55.  
  56. VAR
  57.    WholePal : Array[1..256,1..3] of Byte;
  58.    CurX,CurY,CurCol : Word;
  59.    right,down:Boolean;
  60.  
  61.  
  62. {──────────────────────────────────────────────────────────────────────────}
  63. Procedure SetMCGA;  { This procedure gets you into 320x200x256 mode. }
  64. BEGIN
  65.   asm
  66.      mov        ax,0013h
  67.      int        10h
  68.   end;
  69. END;
  70.  
  71.  
  72. {──────────────────────────────────────────────────────────────────────────}
  73. Procedure SetText;  { This procedure returns you to text mode.  }
  74. BEGIN
  75.   asm
  76.      mov        ax,0003h
  77.      int        10h
  78.   end;
  79. END;
  80.  
  81.  
  82. {──────────────────────────────────────────────────────────────────────────}
  83. procedure WaitRetrace; assembler;
  84. label
  85.   l1, l2;
  86. asm
  87.     mov dx,3DAh
  88. l1:
  89.     in al,dx
  90.     and al,08h
  91.     jnz l1
  92. l2:
  93.     in al,dx
  94.     and al,08h
  95.     jz  l2
  96. end;
  97.  
  98.  
  99. {──────────────────────────────────────────────────────────────────────────}
  100. Procedure GetPal(ColorNo : Byte; Var R,G,B : Byte);
  101.   { This reads the values of the Red, Green and Blue values of a certain
  102.     color and returns them to you. }
  103. Begin
  104.    Port[$3c7] := ColorNo;
  105.    R := Port[$3c9];
  106.    G := Port[$3c9];
  107.    B := Port[$3c9];
  108. End;
  109.  
  110.  
  111. {──────────────────────────────────────────────────────────────────────────}
  112. Procedure Pal(ColorNo : Byte; R,G,B : Byte);
  113.   { This sets the Red, Green and Blue values of a certain color }
  114. Begin
  115.    Port[$3c8] := ColorNo;
  116.    Port[$3c9] := R;
  117.    Port[$3c9] := G;
  118.    Port[$3c9] := B;
  119. End;
  120.  
  121.  
  122. {──────────────────────────────────────────────────────────────────────────}
  123. Procedure FadeDown;
  124.   { This procedure fades the screen out to black. }
  125. VAR loop1,loop2:integer;
  126.     Tmp : Array [1..3] of byte;
  127.       { This is temporary storage for the values of a color }
  128. BEGIN
  129.   For loop1:=1 to 64 do BEGIN
  130.     WaitRetrace;
  131.     For loop2:=1 to 255 do BEGIN
  132.       Getpal (loop2,Tmp[1],Tmp[2],Tmp[3]);
  133.       If Tmp[1]>0 then dec (Tmp[1]);
  134.       If Tmp[2]>0 then dec (Tmp[2]);
  135.       If Tmp[3]>0 then dec (Tmp[3]);
  136.         { If the Red, Green or Blue values of color loop2 are not yet zero,
  137.           then, decrease them by one. }
  138.       Pal (loop2,Tmp[1],Tmp[2],Tmp[3]);
  139.         { Set the new, altered pallette color. }
  140.     END;
  141.   END;
  142. END;
  143.  
  144.  
  145.  
  146. {──────────────────────────────────────────────────────────────────────────}
  147. Procedure Putpixel (X,Y : Integer; Col : Byte);
  148.   { This puts a pixel on the screen by writing directly to memory. }
  149. BEGIN
  150.   Mem [VGA:X+(Y*320)]:=Col;
  151. END;
  152.  
  153.  
  154. {──────────────────────────────────────────────────────────────────────────}
  155. Procedure CunninglyManipulatePalette;
  156.    { This moves up the pallette by one so that the color of the block
  157.      being put down is always the same }
  158. Var
  159.    Tmp : Array[1..3] of byte;
  160.   loop : Byte;
  161. Begin
  162.    Move(WholePal[210],Tmp[1],3);           { Save Last Colour             }
  163.    Move(WholePal[1],WholePal[2],209*3);    { Move Rest Up one             }
  164.    Move(Tmp,WholePal[1],3);                { Put Last Colour to First pos }
  165.    For Loop := 1 to 210 do
  166.       Pal(Loop,WholePal[Loop,1],WholePal[Loop,2],WholePal[Loop,3]);
  167. End;
  168.  
  169.  
  170.  
  171. {──────────────────────────────────────────────────────────────────────────}
  172. Procedure PreparePalette;
  173.    { This sets up the palette to have pretty gradients in it for our use }
  174. Var
  175.    Loop : Byte;
  176. Begin
  177.    For loop := 1 to 30 do BEGIN
  178.       Wholepal [loop,1]:=loop*2;
  179.       Wholepal [loop,2]:=0;
  180.       Wholepal [loop,3]:=0;
  181.    END;
  182.  
  183.    For loop := 31 to 60 do BEGIN
  184.       Wholepal [loop,1]:=0;
  185.       Wholepal [loop,2]:=loop*2-30;
  186.       Wholepal [loop,3]:=0;
  187.    END;
  188.  
  189.  
  190.    For loop := 61 to 90 do BEGIN
  191.       Wholepal [loop,1]:=0;
  192.       Wholepal [loop,2]:=0;
  193.       Wholepal [loop,3]:=loop*2-30;
  194.    END;
  195.  
  196.    For loop := 91 to 120 do BEGIN
  197.       Wholepal [loop,1]:=loop*2-30;
  198.       Wholepal [loop,2]:=loop*2-30;
  199.       Wholepal [loop,3]:=loop*2-30;
  200.    END;
  201.  
  202.    For loop := 121 to 150 do BEGIN
  203.       Wholepal [loop,1]:=loop*2-30;
  204.       Wholepal [loop,2]:=loop*2-30;
  205.       Wholepal [loop,3]:=0;
  206.    END;
  207.  
  208.    For loop := 151 to 180 do BEGIN
  209.       Wholepal [loop,1]:=0;
  210.       Wholepal [loop,2]:=loop*2-30;
  211.       Wholepal [loop,3]:=loop*2-30;
  212.    END;
  213.  
  214.    For loop := 181 to 210 do BEGIN
  215.       Wholepal [loop,1]:=loop*2-30;
  216.       Wholepal [loop,2]:=0;
  217.       Wholepal [loop,3]:=loop*2-30;
  218.    END;
  219. End;
  220.  
  221.  
  222. {──────────────────────────────────────────────────────────────────────────}
  223. Procedure IngeniouslyMoveCurPos;
  224.    { This moves the position of the block to put down around the screen }
  225. Begin
  226.    CurCol := (CurCol) mod 210 + 1;        { This Does Work                }
  227.    if right then CurX := CurX + 4 else CurX := CurX - 3;
  228.    if down then CurY := CurY + 3 else CurY := CurY - 2;
  229.  
  230.    If CurX > 250 then right:= FALSE;
  231.    If CurY > 150 then down := FALSE;
  232.  
  233.    If CurX < 10 then right := TRUE;
  234.    If CurY < 10 then down  := TRUE;
  235.  
  236. End;
  237.  
  238.  
  239. {──────────────────────────────────────────────────────────────────────────}
  240. Procedure DrawBlock;
  241.    { This draws the block onto the VGA screen }
  242. Var
  243.    Xloop,Yloop : Integer;
  244. Begin
  245.    For XLoop := 1 to 40 do
  246.       For Yloop := 1 to 40 do
  247.          If block[Yloop,Xloop] = 1 then
  248.             PutPixel(CurX+Xloop,CurY+Yloop,CurCol);
  249. End;
  250.  
  251.  
  252. {──────────────────────────────────────────────────────────────────────────}
  253. Procedure StartSnakiepoo;
  254.    { This is the proc where we set things up & set em in motion! ;-) }
  255. Begin
  256.    CurX := 100;
  257.    CurY := 100;
  258.    CurCol := 1;
  259.    PreparePalette;
  260.    Repeat
  261.       DrawBlock;
  262.       CunninglyManipulatePalette;
  263.       IngeniouslyMoveCurPos;
  264.    Until Keypressed;
  265.    fadedown;
  266.    Readkey;
  267. End;
  268.  
  269. Begin
  270.    ClrScr;
  271.    Writeln ('Hi there!  This is a small little routine that Livewire');
  272.    Writeln ('and Denthor of ASPHYXIA threw together during lunch break');
  273.    Writeln ('at varsity. We first saw this routine in the T-Holic demo');
  274.    Writeln ('by Extreme a few months back, and decided to write it as');
  275.    Writeln ('a supliment to the ASPHYXIA VGA Demo Trainer Series on the');
  276.    Writeln ('MailBox BBS here in Durban.                              ');
  277.    Writeln;
  278.    Writeln ('The routine consists of a wormy type thing bouncing around');
  279.    Writeln ('the screen, and looks quite effective. The code is');
  280.    Writeln ('documented, and the concept behind it is so easy everyone');
  281.    Writeln ('should be able to understand it.                         ');
  282.    Writeln;
  283.    Writeln ('The Pal routines, setmcga, waitretrace etc. are taken');
  284.    Writeln ('directly from the ASPHYXIA Trainer Series, and you should');
  285.    Writeln ('read those to understand how they work.');
  286.    Writeln;
  287.    Writeln ('See the Trainer Series for how to get into contact with us.');
  288.    Writeln; Writeln;
  289.    Writeln ('Hit any key to continue ....                             ');
  290.    Readkey;
  291.    SetMCGA;
  292.    StartSnakiepoo;
  293.    SetText;
  294.    Writeln ('All done. This was a sample routine written by ASPHYXIA.');
  295.    Writeln ('Please read the ASPHYXIA Demo Trainer Series on the MailBox BBS,');
  296.    Writeln ('written by Denthor. You may reach DENTHOR under the name of GRANT');
  297.    Writeln ('SMITH on the MailBox BBS, or leave a message to ASPHYXIA on the');
  298.    Writeln ('ASPHYXIA BBS. Get the numbers from Roblist, or write to :');
  299.    Writeln ('             Grant Smith');
  300.    Writeln ('             P.O. Box 270');
  301.    Writeln ('             Kloof');
  302.    Writeln ('             3640');
  303.    Writeln ('We hope to hear from you soon!');
  304.    Writeln; Writeln;
  305.    Write   ('Hit any key to exit ...');
  306.    Readkey;
  307. End.