{some procedures and scale, blur asm with small changes from 
 Fuzzy feedback intro fuzzy.zip}  
{$G+}{$M 5000,0,40000}
uses crt,mygraph,pcxunitz;
const factor=7;
type palette=array[0..767] of byte;
var bseg,bseg2,vpisaddr:word;
    xarray:array[0..319] of word;
    yarray:array[0..399] of word;
    cosinus:array[0..255] of byte;
    sinus:array[0..255] of byte;
    pal:palette;
    x,y:byte;
    i:word;
    dotx:word;
    stop:boolean;
    takt:word;

{$l scale.obj}
procedure ScaleUp(source,dest:word);External; { This is where the stuff goes }
procedure Fire(dest:word);External;           { Standard blur }
procedure CopyDW(source,dest:word);External;  { 32-bit copy }
procedure Dot(x,y,where:word;c:byte);External;{ No circle :-( }


procedure virtputpixel(where:word;x,y:integer;col:byte);
begin
 asm
  push es
  mov es,where
  mov ax,[y]
  shl ax,6
  mov di,ax
  shl ax,2
  add di,ax
  add di,[x]
  mov al,col
  mov [es:di],al
  pop es
 end;
end;


procedure SetPal;assembler;
asm
  cli
  mov si,offset pal
  mov DX,3dah
  @l1:
  in AL,DX
  test AL,8d
  jnz @l1
  @l2:
  in AL,DX
  test AL,8d
  jz @l2
  mov cx,768
  mov dx,3C8h
  xor al,al
  out dx,al
  inc dx
  rep outsb
  sti
END;

procedure ramp(scol,r1,g1,b1,ecol,r2,g2,b2:byte;var p:palette);
{ramp colors}
var i:word;
    r,g,b:real;
begin
  i:=scol;
  r:=(r2-r1)/(ecol-scol);
  g:=(g2-g1)/(ecol-scol);
  b:=(b2-b1)/(ecol-scol);
  repeat
    p[i*3]  :=r1+round(r*(i-scol));
    p[i*3+1]:=g1+round(g*(i-scol));
    p[i*3+2]:=b1+round(b*(i-scol));
    inc(i);
  until i=ecol+1;
end;

procedure SetUpBuffer(var segment:word;size:word);
{I HATE GETMEM}
var StartAdress:word;
begin
  asm
    mov ax,4800h
    mov bx,size
    int 21h
    mov dx,ax
    jnb @l1
      mov dx,0a000h
      jmp @l2
    @l1:
      shl bx,2
      mov cx,bx
      mov es,ax
      xor di,di
      xor ax,ax
      rep stosw
    @l2:
    mov StartAdress,dx
  end;
  segment:=StartAdress;
  if StartAdress=$0a000 then begin
    asm mov ax,3h;int 10h;end;
    Writeln('Critical error - not enough memory to setup buffer');
    halt;
  end;
end;

procedure FreeBuffer(segment:word);assembler;
{I HATE FREEMEM, TOO}
asm
  mov ax,4921h
  mov bx,segment
  int 21h
end;

procedure init;
var i:word;
begin
  SetUpBuffer(bseg,4096);
  SetUpBuffer(bseg2,4096);
  SetUpBuffer(vpisaddr,4096);
  pcxvirt('pismo.pcx',vpisaddr);       {nacte obrazek s pismem}
  {Just a few precalcs to gain speed}
   for i:=0 to 255 do cosinus[i]:=round(cos(2*pi*i/85)*55+82);
   for i:=0 to 255 do sinus[i]:=round(sin(2*pi*i/85)*100+140);
   for i:=0 to 319 do xarray[i]:=round(i/319*(319-(2*factor)))+factor;
  for i:=0 to 199 do begin
                       yarray[2*i]:=  round(i/199*(199-(2*factor))+factor)*320;
                       yarray[2*i+1]:=round(i/199*(199-(2*factor))+factor)*320;
                     end;
  ramp(  0, 0, 0, 0, 31,26, 3,38,pal);
  ramp( 32,26, 3,38, 63,15,39,63,pal);
  ramp( 64,15,39,63, 95,63,63,63,pal);
  ramp( 96,63,63,63,111,63,63, 3,pal);
  ramp(112,63,63, 3,130,63, 3,27,pal);
  asm
  mov ax,13h
  int 10h
  end;
  setpal;
end;


procedure leave;
begin
  FreeBuffer(bseg);
  FreeBuffer(bseg2);
  FreeBuffer(vpisaddr);
  asm
  mov ax,3
  int 10h
  end;
end;

procedure nejakepismo(x,y,x1,y1,x2,y2,where:integer;color:byte);
var a,b:word;
begin
for a:= x1 to x2 do
 for b:=y1 to y2 do
  begin
   if mem[vpisaddr:a+320*b]=0 then virtputpixel(where,x+a,y+b,color);
  end;
end;

procedure main0(from,at:word);  {dot   only }
var timer:byte;
begin
for timer:=from to at do
 begin
  dotx:=dotx+1;
  dot(sinus[dotx],cosinus[dotx],bseg,142);
  fire(bseg);
  ScaleUp(bseg,bseg2);
  waitretrace;
  copyDW(bseg2,$0a000);
  for i:=1 to 40 do dot(random(320),random(150)+15,bseg2,100);
  dot(sinus[dotx],cosinus[dotx],bseg2,142);
  fire(bseg2);
  ScaleUp(bseg2,bseg);
  waitretrace;
  copyDW(bseg,$0a000);
  if port[$60]=$01 then
   begin
    timer:=at;
    stop:=true;
   end;
 end;
end;

procedure main1(from,at:word);  {drumm'n'bass INside}
var x:byte;
begin
for x:=from to at do
 begin
  dotx:=dotx+1;
  dot(sinus[dotx],cosinus[dotx],bseg,142);
  nejakepismo(20,40,31,9,262,82,bseg,x);
  fire(bseg);
  ScaleUp(bseg,bseg2);
  waitretrace;
  copyDW(bseg2,$0a000);
  for i:=1 to 40 do dot(random(320),random(150)+15,bseg2,100);
  dot(sinus[dotx],cosinus[dotx],bseg2,142);
  nejakepismo(20,40,31,9,262,82,bseg2,x);
  fire(bseg2);
  ScaleUp(bseg2,bseg);
  waitretrace;
  copyDW(bseg,$0a000);
  if port[$60]=$01 then
   begin
    x:=at;
    stop:=true;
   end;
 end;
end;

procedure main2(from,at:word); {intel OUTSIDE}
var x:byte;                    {I know , stupid, but I'm to lazy}
begin
for x:=from to at do
 begin
  dotx:=dotx+1;
  nejakepismo(70,-40,8,87,167,183,bseg,x);
  dot(sinus[dotx],cosinus[dotx],bseg,142);
  fire(bseg);
  ScaleUp(bseg,bseg2);
  waitretrace;
  copyDW(bseg2,$0a000);
  for i:=1 to 40 do dot(random(320),random(150)+15,bseg2,100);
  nejakepismo(70,-40,8,87,167,183,bseg2,x);
  dot(sinus[dotx],cosinus[dotx],bseg2,142);
  fire(bseg2);
  ScaleUp(bseg2,bseg);
  waitretrace;
  copyDW(bseg,$0a000);
  if port[$60]=$01 then
   begin
    x:=at;
    stop:=true;
   end;
 end;
end;

procedure fade(timer:byte;maxframe:integer);
var a:integer;
begin
if timer>=(maxframe-64) then
 begin
  for a:=0 to 255 do
   begin
    if activepal[a,1]>0 then
     activepal[a,1]:=ActivePal[a,1]-1;
    if activepal[a,2]>0 then
     activepal[a,2]:=ActivePal[a,2]-1;
    if activepal[a,3]>0 then
     activepal[a,3]:=ActivePal[a,3]-1;
   end;
   setpalette;
  end;
end;


procedure main3(from,at:word);  {fade doting }
var timer:byte;
begin
for timer:=from to at do
 begin
  dotx:=dotx+1;
  dot(sinus[dotx],cosinus[dotx],bseg,142);
  fire(bseg);
  ScaleUp(bseg,bseg2);
  waitretrace;
  copyDW(bseg2,$0a000);
  for i:=1 to 40 do dot(random(320),random(150)+15,bseg2,100);
  dot(sinus[dotx],cosinus[dotx],bseg2,142);
  fire(bseg2);
  ScaleUp(bseg2,bseg);
  waitretrace;
  fade(timer,at);
  copyDW(bseg,$0a000);
  if port[$60]=$01 then
   begin
    timer:=at;
    stop:=true;
   end;
 end;
end;


begin
  init;
  getpalette;
  dotx:=0;
  main0(0,168);
  dotx:=0;
  if not(stop) then main1(0,130);
  for takt:=1 to 30 do
   begin
    if stop then break;
    main1(130,130);
   end;
  inc(dotx);
  if not(stop) then main1(130,137);
  dotx:=0;
  if not(stop) then main0(0,168);
  dotx:=0;
  if not(stop) then main2(0,130);
  for takt:=1 to 30 do
   begin
    if stop then break;
    main2(130,130);
   end;
  inc(dotx);
  if not(stop) then main2(130,137);
  dotx:=0;
  if not(stop) then main3(0,168);
  leave;
end.