home *** CD-ROM | disk | FTP | other *** search
/ The Party 1994: Try This At Home / disk_image.bin / source / fakesrc / part8 / genworm.pas next >
Pascal/Delphi Source File  |  1993-10-21  |  2KB  |  99 lines
  1. { Renders the WormHole Picture. Saves in WORM.RAW file. }
  2. program RenderWormHole;
  3. uses crt;
  4.  
  5. const
  6.   XDOTS   = 320;
  7.   YDOTS   = 200;
  8.   XCENTER = 160;
  9.   YCENTER = 50;
  10.   DIVS    = 1000;
  11.   SPOKES  = 20*16*5;
  12.   FACTOR  = 65536;
  13. var
  14.   costable,sintable: array [0..SPOKES-1] of longint;
  15.   functable: array [1..DIVS-1] of longint;
  16.  
  17. procedure initgraph; assembler;
  18. asm
  19.    mov  ax,13h
  20.    int  10h
  21. end;
  22.  
  23. procedure deinit; assembler;
  24. asm
  25.    mov  ax,03h
  26.    int  10h
  27. end;
  28.  
  29. procedure setpalettecol(color,red,green,blue: byte); assembler;
  30. asm
  31.    mov  dx,3C8h
  32.    mov  al,[color]
  33.    out  dx,al
  34.    inc  dx
  35.    mov  al,[red]
  36.    out  dx,al
  37.    mov  al,[green]
  38.    out  dx,al
  39.    mov  al,[blue]
  40.    out  dx,al
  41. end;
  42.  
  43. procedure putpixel(x,y:integer; color:byte);
  44. begin Mem[$A000:x+XDOTS*y]:=color;
  45. end;
  46.  
  47. procedure setpalette;
  48. var k,l:integer;
  49. begin
  50.   for l:=0 to 14 do
  51.     for k:=0 to 15 do
  52.       setpalettecol(16+k+16*l, 4*(k and 15),4*(l mod 15),63);
  53. end;
  54.  
  55. procedure render;
  56. var
  57.   x,y,i,j,color:integer;
  58. begin
  59.   for i := 0 to SPOKES-1 do begin
  60.     costable[i] := round(FACTOR * 320/DIVS*cos(2*Pi*i/SPOKES));
  61.     sintable[i] := round(FACTOR * 240/DIVS*sin(2*Pi*i/SPOKES));
  62.   end;
  63.  
  64.   for j := 1 to DIVS-1 do begin
  65.     functable[j] := {round(FACTOR * 30*(-1.0+ln(2.0*j/DIVS)));}
  66.       round(FACTOR * 200*(-0.6+0.6*sin(Pi*j/DIVS)));
  67.   end;
  68.  
  69.   for j:=1 to DIVS-1 do begin
  70.     color := {16+16*(14-((abs(functable[j]) div (FACTOR div 2)) mod 15));}
  71.       16+16*((j div 5) mod 15);
  72.     for i:=0 to SPOKES-1 do begin
  73.       x := XCENTER + (j*costable[i]) div FACTOR;
  74.       y := YCENTER + ((j*sintable[i]) - functable[j]) div FACTOR;
  75.       if (x>=0) and (x<XDOTS) and (y>=0) and (y<YDOTS) then begin
  76.         putpixel(x,y,color + ((i div 5) mod 16));
  77.       end;
  78.     end;
  79.   end;
  80. end;
  81.  
  82. procedure savepic;
  83. var F:file;
  84. begin
  85.   assign(f,'WORM.RAW');
  86.   rewrite(f,1);
  87.   blockwrite(f,mem[$a000:0],xdots*ydots);
  88.   close(f);
  89. end;
  90.  
  91. begin
  92.   initgraph;
  93.   setpalette;
  94.   render;
  95.   savepic;
  96.   sound(1000); delay(50); nosound; {readkey;}
  97.   deinit;
  98. end.
  99.