home *** CD-ROM | disk | FTP | other *** search
/ The Unsorted BBS Collection / thegreatunsorted.tar / thegreatunsorted / programming / asm_programming / GRUMP3D.ZIP / STARS.PAS < prev   
Pascal/Delphi Source File  |  1993-10-08  |  3KB  |  132 lines
  1. { This is a simple 3D Stars Program for Grumpy so he can see some 3D Stars }
  2. { written by Ken Sallot on 10/8/93 }
  3.  
  4. Program Stars(Input,Output);  { Standard Pascal Header oooh ahhhh }
  5.  
  6. Uses Dos, Crt;
  7.  
  8. Type StarRow = Array[1..80] of char;
  9.      StarField = Array[1..25] of StarRow;
  10.  
  11. Var SlowStars, MedStars, FastStars : StarField;
  12.     I,B : Integer; { Counter }
  13.  
  14.  
  15. Procedure SetupStars;
  16. var randfill : byte;
  17. begin
  18.   fillchar(SlowStars, SizeOf(SlowStars), 0);
  19.   MedStars := SlowStars;
  20.   FastStars := MedStars;
  21.   Randomize;  { Install Random Seed Kernel }
  22.   For I := 1 to 8 do
  23.   begin
  24.     for b := 1 to 5 do
  25.     begin
  26.        randfill := Random(80)+1;
  27.        SlowStars[i*3-2][randfill] := '∙';
  28.     end;
  29.     for b := 1 to 5 do
  30.     begin
  31.       randfill := Random(80)+1;
  32.       MedStars[i*3-1][randfill] := '∙';
  33.     end;
  34.     for b := 1 to 5 do
  35.     begin
  36.       RandFill := Random(80)+1;
  37.       FastStars[i*3][randfill] := '.';
  38.     end;
  39.   end;
  40. end;  { SetupStars }
  41.  
  42. Procedure SetMode13h;
  43. Begin
  44.   Asm
  45.     Mov ah, 13h
  46.     int 10h
  47.   end
  48. end;
  49.  
  50. Procedure DisplayAllStars;
  51. var tpg : array[1..8000] of char;
  52.     az1 : array[1..4000] of char;
  53. begin
  54.   fillchar(tpg,sizeof(tpg),0);
  55.   Move(slowstars,az1,sizeof(slowstars));  { This aint too kosher but I know
  56.                            what I'se bee doin' }
  57.   for i := 1 to 4000 do
  58.     if az1[i]<>#0 then
  59.     begin
  60.       tpg[i*2-1] := az1[i];
  61.       tpg[i*2] := #8;
  62.     end;
  63.   Move(Medstars,az1,sizeof(Medstars));  { This aint too kosher but I know
  64.                            what I'se bee doin' }
  65.   for i := 1 to 4000 do
  66.     if az1[i]<>#0 then
  67.     begin
  68.       tpg[i*2-1] := az1[i];
  69.       tpg[i*2] := #7;  { higher intensity for medium stars }
  70.     end;
  71.   Move(Faststars,az1,sizeof(Faststars));  { This aint too kosher but I know
  72.                            what I'se bee doin' }
  73.   for i := 1 to 4000 do
  74.     if az1[i]<>#0 then
  75.     begin
  76.       tpg[i*2-1] := az1[i];
  77.       tpg[i*2] := #15;  { higher intensity for medium stars }
  78.     end;
  79.  
  80.   repeat                     { check for vertical retrace }
  81.   until port[$3da] and 8=0;
  82.   repeat until port[$3da] and 8<>0;
  83.  
  84.   move(tpg,Mem[$B800:0],sizeof(tpg));   { Dump to video }
  85. End;
  86.  
  87. Procedure MoveStars;
  88. var temp : starfield;
  89. begin
  90.   fillchar(temp,sizeof(temp),0);
  91.   if b=4 then
  92.   begin
  93.    for i := 1 to 25 do
  94.       move(slowstars[i][2],temp[i][1],79);
  95.    slowstars := temp;
  96.    for i := 1 to 8 do
  97.        if random(20)=1 then slowstars[i*3-2][80] := '∙';
  98.   end; { if b=3 then begin }
  99.  
  100.   fillchar(temp,sizeof(temp),0);
  101.   for i := 1 to 25 do
  102.     move(faststars[i][2],temp[i][1],79);
  103.   faststars := temp;
  104.   for i := 1 to 8 do
  105.     if random(20)=1 then faststars[i*3][80] := '.';
  106.  
  107.   fillchar(temp,sizeof(temp),0);
  108.   if (b/2) = (b div 2) then
  109.   begin
  110.     for i := 1 to 25 do
  111.       move(medstars[i][2],temp[i][1],79);
  112.     medstars := temp;
  113.     for i := 1 to 8 do if random(20)=1 then medstars[i*3-1][80] := '∙';
  114.   end;
  115.  
  116.   inc(b);
  117.   if b=5 then b := 1;
  118. end;
  119.  
  120.  
  121. Begin
  122.    ClrScr;
  123.    SetupStars;
  124.    b := 1;
  125.    repeat
  126.      DisplayAllStars;
  127.      movestars;
  128.    until keypressed;
  129.    while keypressed do ReadKey;
  130.    clrscr;
  131.    WriteLn('3D Stars written by Ken Sallot ');
  132. End.