home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / graphics.swg / 0042_Wormhole.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-05-25  |  1.6 KB  |  70 lines
  1. {
  2. MSGID: 1:108/180 868965DB
  3. Well, here is the cool wormhole program that everybody has been awaiting.
  4.  
  5. It consists of three programs, WGEN, PGEN, and WORMHOLE. The WGen program
  6. generates the data file for the wormhole. PGen generates a palette file
  7. for the wormhole. WORMHOLE actually runs the program once everything is done.
  8.  
  9. ************  Listing of WGEN.PAS
  10. }
  11.  
  12. {$N+,E+,G+}
  13. Program WGen;
  14. {actually generates the Wormhole, SLOW}
  15. { math co-processor HIGHLY recommended }
  16.  
  17. Uses Crt;
  18.  
  19. Const
  20.   Stretch = 25;     XCenter = 160;
  21.   YCenter = 50;     DIVS = 1200;
  22.   SPOKES = 2400;
  23.  
  24. Procedure TransArray;
  25.  
  26. Var
  27.   x, y, z : Real;
  28.   i, j, color : Integer;
  29.  
  30. Begin
  31.   For j := 1 to DIVS do
  32.     Begin
  33.       For i := 0 to (Spokes-1) do
  34.         Begin
  35.           z := (-1.0)+(Ln(2.0*j/DIVS));
  36.           x := (320.0*j/DIVS*cos(2*Pi*i/SPOKES));
  37.           y := (240.0*j/DIVS*sin(2*Pi*i/Spokes));
  38.           y := y-STRETCH*z;
  39.           x := x + XCenter;
  40.           y := y + YCenter;
  41.           Color := (Round(i/8) Mod 15)+15*(Round(j/6) MOD 15)+1;
  42.           if ((X>=0)and(x<320)and(Y>=0)and(y<200))
  43.             Then Mem[$A000:Round(x) + (Round(y) * 320)] := Color;
  44.         End;
  45.     End;
  46. End;
  47.  
  48. Procedure SaveImage;
  49.  
  50. Var
  51.   i, j : Integer;
  52.   Diskfile : File of Byte;
  53.  
  54. Begin
  55.   Assign(Diskfile, 'Ln.DAT');
  56.   Rewrite(Diskfile);
  57.   For i := 0 to 199 do
  58.     For j := 0 to 319 do
  59.       Write(Diskfile, Mem[$A000:j + (320 * i)]);
  60.   Close(Diskfile);
  61. End;
  62.  
  63. Begin
  64.   Asm  MOV  AX,$13; INT $10; End;
  65.   FillChar(Mem[$A000:$0000], 64000, 0);
  66.   transarray;
  67.   SaveImage;
  68.   Asm MOV  AX,3; INT $10; End;
  69. End.
  70.