home *** CD-ROM | disk | FTP | other *** search
/ Mega A/V / mega_av.zip / mega_av / DEMOS / PLASMA.ZIP / PLASMA.PAS < prev   
Pascal/Delphi Source File  |  1988-06-24  |  4KB  |  145 lines
  1. { Turbo Pascal 4.0 source code }
  2. {$I-}
  3. program plasma;
  4.  
  5.   uses
  6.     Crt,Dos;
  7.  
  8.   const
  9.     F = 2.0; { the "roughness" of the image }
  10.  
  11.   type
  12.     ColorValue = record Rvalue,Gvalue,Bvalue: byte; end;
  13.     PaletteType = array [0..255] of ColorValue;
  14.  
  15.   var
  16.     ch: char;
  17.     i: integer;
  18.     p: PaletteType;
  19.     image: file;
  20.     ok: boolean;
  21.  
  22.   procedure SetVGApalette(var tp: PaletteType);
  23.     var regs: Registers;
  24.   begin { procedure SetVGApalette }
  25.     with regs do
  26.       begin
  27.         AX:=$1012;
  28.         BX:=0; { first register to set }
  29.         CX:=256; { number of registers to set }
  30.         ES:=Seg(tp); DX:=Ofs(tp);
  31.       end;
  32.     Intr($10,regs);
  33.   end; { procedure SetVGApalette }
  34.  
  35.   procedure PutPixel(x,y: integer; c: byte);
  36.   begin { procedure PutPixel }
  37.     mem[$A000:word(320*y+x)]:=c;
  38.   end; { procedure PutPixel }
  39.  
  40.   function GetPixel(x,y: integer): byte;
  41.   begin { function GetPixel }
  42.     GetPixel:=mem[$A000:word(320*y+x)];
  43.   end; { function GetPixel }
  44.  
  45.   procedure adjust(xa,ya,x,y,xb,yb: integer);
  46.     var
  47.       d: integer;
  48.       v: real;
  49.   begin { procedure adjust }
  50.     if GetPixel(x,y)<>0 then exit;
  51.     d:=Abs(xa-xb)+Abs(ya-yb);
  52.     v:=(GetPixel(xa,ya)+GetPixel(xb,yb))/2+(random-0.5)*d*F;
  53.     if v<1 then v:=1;
  54.     if v>=193 then v:=192;
  55.     PutPixel(x,y,Trunc(v));
  56.   end; { procedure adjust }
  57.  
  58.   procedure subDivide(x1,y1,x2,y2: integer);
  59.     var
  60.       x,y: integer;
  61.       v: real;
  62.   begin { procedure subDivide }
  63.     if KeyPressed then exit;
  64.     if (x2-x1<2) and (y2-y1<2) then exit;
  65.  
  66.     x:=(x1+x2) div 2;
  67.     y:=(y1+y2) div 2;
  68.  
  69.     adjust(x1,y1,x,y1,x2,y1);
  70.     adjust(x2,y1,x2,y,x2,y2);
  71.     adjust(x1,y2,x,y2,x2,y2);
  72.     adjust(x1,y1,x1,y,x1,y2);
  73.  
  74.     if GetPixel(x,y)=0 then
  75.       begin
  76.         v:=(GetPixel(x1,y1)+GetPixel(x2,y1)+GetPixel(x2,y2)+GetPixel(x1,y2))/4;
  77.         PutPixel(x,y,Trunc(v));
  78.       end;
  79.  
  80.     subDivide(x1,y1,x,y);
  81.     subDivide(x,y1,x2,y);
  82.     subDivide(x,y,x2,y2);
  83.     subDivide(x1,y,x,y2);
  84.   end; { procedure subDivide }
  85.  
  86.   procedure rotatePalette(var p: PaletteType; n1,n2,d: integer);
  87.     var
  88.       q: PaletteType;
  89.   begin { procedure rotatePalette }
  90.     q:=p;
  91.     for i:=n1 to n2 do
  92.       p[i]:=q[n1+(i+d) mod (n2-n1+1)];
  93.     SetVGApalette(p);
  94.   end; { procedure rotatePalette }
  95.  
  96. begin
  97.   Inline($B8/$13/0/$CD/$10); { select video mode 13h (320x200 with 256 colors) }
  98.  
  99.   with p[0] do               { set background palette entry to grey }
  100.     begin
  101.       Rvalue:=32;
  102.       Gvalue:=32;
  103.       Bvalue:=32;
  104.     end;
  105.  
  106.   for i:=0 to 63 do { create the color wheel }
  107.     begin
  108.       with p[i+1] do begin Rvalue:=i; Gvalue:=63-i; Bvalue:=0; end;
  109.       with p[i+65] do begin Rvalue:=63-i; Gvalue:=0; Bvalue:=i; end;
  110.       with p[i+129] do begin Rvalue:=0; Gvalue:=i; Bvalue:=63-i; end;
  111.     end;
  112.  
  113.   SetVGApalette(p);
  114.  
  115.   Assign(image,'PLASMA.IMG');
  116.   Reset(image,1);
  117.   ok:=(ioResult=0);
  118.  
  119.   if not ok or (ParamCount<>0) then { create a new image }
  120.     begin
  121.       Randomize;
  122.  
  123.       PutPixel(0,0,1+Random(192));
  124.       PutPixel(319,0,1+Random(192));
  125.       PutPixel(319,199,1+Random(192));
  126.       PutPixel(0,199,1+Random(192));
  127.  
  128.       subDivide(0,0,319,199);
  129.  
  130.       Rewrite(image,1);
  131.       BlockWrite(image,mem[$A000:0],$FA00);
  132.     end
  133.   else { use the previous image }
  134.     BlockRead(image,mem[$A000:0],$FA00);
  135.  
  136.   Close(image);
  137.  
  138.   repeat
  139.     rotatePalette(p,1,192,+1);
  140.   until KeyPressed;
  141.  
  142.   ch:=ReadKey; if ch=#0 then ch:=ReadKey;
  143.  
  144.   TextMode(LastMode);
  145. end.