program circledesign;

{$A+,B-,E+,F-,G+,N+,Q-,R-,S-}

uses crt;


{above is needed for x and y flip, 286/386 instructions }


Const VGA=$A000;
      Npages=2;
      MinX=0;
      MaxX=319;
      MinY=0;
      MaxY=199;

Type RgbItem=Record
                   R,G,B:Byte;
             End;
     RgbList=Array[0..255] of RgbItem;
     Table=Array[0..1799] Of integer;
     PTable=^Table;

Var Sines:Ptable;
    Cosines:Ptable;
    Virt:Array[1..Npages] Of Pointer;
    VP:Array[1..Npages] Of Word;

Procedure video_mode (mode : Byte); Assembler;
Asm
  mov  AH,00
  mov  AL,mode
  int  10h
end;

Procedure Cls(Col:Byte;Where:Word);
Begin
     Fillchar(Mem[Where:0000],64000,Col);
End;

Procedure WaitVBL; Assembler;
Label A1,A2;
Asm
   Mov DX,3DAh
   A1:
      In AL,DX
      And AL,08h
      Jnz A1
   A2:
      In AL,DX
      And AL,08h
      Jz A2
End;

Procedure GetColor(Col:Byte;Var R,G,B:Byte);
Begin
     Port[$3C7]:=Col;
     R:=Port[$3C9];
     G:=Port[$3C9];
     B:=Port[$3C9];
End;

Procedure SetColor(Col,R,G,B:Byte);
Begin
     Port[$3C8]:=Col;
     Port[$3C9]:=R;
     Port[$3C9]:=G;
     Port[$3C9]:=B;
End;

Procedure InitTables;
Var A:Word;
    B:Real;
Begin
     Getmem(Sines,Sizeof(Sines^));
     Getmem(Cosines,Sizeof(Cosines^));
     B:=0;
     For A:=0 To 1799 Do
     Begin
          Sines^[A]:=round(Sin(B)*100);
          Cosines^[A]:=round(Cos(B)*100);
          B:=B+0.005;
     End;
End;

Procedure ClearTables;
Begin
     Freemem(Sines,Sizeof(Sines^));
     Freemem(Cosines,Sizeof(Cosines^));
End;

Procedure InitVirt;
Var A:Byte;
Begin
     For A:=1 To Npages Do
     Begin
          GetMem(Virt[A],64000);
          VP[A]:=Seg(Virt[A]^);
     End;
End;

Procedure CloseVirt;
Var A:Byte;
Begin
     For A:=1 To Npages Do
     Begin
          Freemem(Virt[A],64000);
          VP[A]:=$A000;
     End;
End;

Procedure CopyPage(From,Too:Word;a:integer);
var m:word;
Begin
     for m:=0 to 64000 do
         begin
              if mem[from:m]<>a then Move(Mem[From:m],Mem[Too:m],1);
         end;
End;

Procedure PutPixel(X,Y:word;Col:Byte;Where:Word);
Begin
     if x>-1 then if x<320 then if y>-1 then if y<200 then
     Mem[Where:(y*320)+x]:=Col;
End;

Function GetPixel(X,Y:word;Where:Word):Byte;
Begin
     GetPixel:=Mem[Where:(y*320)+x];
End;

Procedure SetPalette(Pal:RgbList);
Var A:Byte;
Begin
     WaitVBL;
     For A:=0 To 255 do SetColor(A,Pal[A].R,Pal[A].G,Pal[A].B);
End;

Procedure LoadPCX(Filename:String;Where:Word);
Var Fil:File;
    Dx,Dy:Word;
    J,M:Byte;
    Ph:Word;
    Buff:Array[0..127] of byte;
    PCXPal:RgbList;
Begin
     Assign(Fil,Filename);
     Reset(Fil,1);
     Blockread(Fil,Buff,128);
     Dy:=0;
     Repeat
           Dx:=0;
           Repeat
                 BlockRead(Fil,J,1);
                 If J>192 Then
                 Begin
                      BlockRead(Fil,M,1);
                      Dec(J,192);
                      For Ph:=1 To J Do
                      Begin
                           PutPixel(Dx,Dy,M,Where);
                           Inc(Dx);
                      End;
                 End
                 Else
                 Begin
                      PutPixel(Dx,Dy,J,Where);
                      Inc(Dx);
                 End;
           Until Dx>=320;
           Inc(Dy);
     Until Dy=200;
     BlockRead(Fil,M,1);
     If M=12 Then
     Begin
          BlockRead(Fil,PCXPal,768);
          For M:=0 To 255 Do
          Begin
               PCXPal[M].R:=PCXPal[M].R Div 4;
               PCXPal[M].G:=PCXPal[M].G Div 4;
               PCXPal[M].B:=PCXPal[M].B Div 4;
          End;
          SetPalette(PCXPal);
     End;
     Close(Fil);
End;

Procedure GetImage(x1,y1,x2,y2:Word;Var Img:Pointer;Where:Word);
Var Dx,Dy:Word;
    A,B:Word;
    Segm,Offs:Word;
Begin
     Dx:=Abs(x2-x1)+1;
     Dy:=Abs(y2-y1)+1;
     GetMem(Img,Dx*Dy+4);
     Segm:=Seg(Img^);
     Offs:=Ofs(Img^);
     Move(Dx,Mem[Segm:Offs],2);
     Move(Dy,Mem[Segm:Offs+2],2);
     Offs:=Offs+4;
     For A:=y1 to y2 Do
     For B:=x1 to x2 Do
     Begin
          Mem[Segm:Offs]:=GetPixel(B,A,Where);
          Inc(Offs);
     End;
End;

Procedure KillImage(Var Img:Pointer);
Var Dx,Dy:Word;
    Segm,Offs:Word;
Begin
     Segm:=Seg(Img^);
     Offs:=Ofs(Img^);
     Move(Mem[Segm:Offs],Dx,2);
     Move(Mem[Segm:Offs+2],Dy,2);
     FreeMem(Img,Dx*Dy+4);
End;

Procedure PutImage(X,Y,C:Integer;Var Img:Pointer;Where:Word);
Var Dx,Dy:Word;
    A,B:Word;
    Segm,Offs:Word;
Begin
     Segm:=Seg(Img^);
     Offs:=Ofs(Img^);
     Move(Mem[Segm:Offs],Dx,2);
     Move(Mem[Segm:Offs+2],Dy,2);
     Offs:=Offs+4;
     A:=Y;
     While (A<=Y+DY-1) And (A<MaxY) Do
     Begin
          B:=X;
          While (B<=X+DX-1) And (B<MaxX) Do
          Begin
               If (X>=MinX) And (Y>=MinY) Then
               if Mem[Segm:Offs]<>c then
                 PutPixel(B,A,Mem[Segm:Offs],Where);
               Inc(Offs);
               Inc(B);
          End;
          Inc(A);
     End;
End;

Procedure PutImage_bob(X,Y,C:Integer;Var Img:Pointer;Where:Word);
const minx=0;
      maxx=319;
      miny=0;
      maxy=199;
Var Dx,Dy:Word;
    A,B:integer;
    Segm,Offs:Word;
    c1,c2,c3:integer;
Begin
     Segm:=Seg(Img^);
     Offs:=Ofs(Img^);
     Move(Mem[Segm:Offs],Dx,2);
     Move(Mem[Segm:Offs+2],Dy,2);
     Offs:=Offs+4;
     for a:=y to y+dy-1 do
     Begin
          for b:=x to x+dx-1 do
          Begin

               if Mem[Segm:Offs]<>c then
               if b>minx then if b<maxx then if a>miny then if a<maxy then
                  begin
                       c1:=getpixel(B,A,where);
                       c2:=mem[segm:offs];
                       c3:=c2+c1;

                       if c3>255 then c3:=255;
                       if c3<0 then c3:=0;
                       PutPixel(B,A,c3,Where);
                  end;
               Inc(Offs);
          End;
     End;
End;

procedure blur_f(from,too:word);
var x,y,aaa,ccc,ccc2,counter:integer;
    cccc: array [1..9] of integer;
begin
     for x:=1 to 318 do for y:=1 to 198 do
         begin
          cccc[1]:=mem[from:(x)+(y+1)*320];
          cccc[2]:=mem[from:(x+1)+(y)*320];
          cccc[3]:=mem[from:(x)+(y)*320];
          cccc[4]:=mem[from:(x-1)+(y)*320];
          cccc[5]:=mem[from:(x)+(y-1)*320];

               ccc2:=(((cccc[1]+cccc[2]+cccc[4]+cccc[5]) div 4) + cccc[3]) div 2;
               mem[too:x+y*320]:=ccc2;

         end;
end;

var c:char;
    a,x,y,deg,add:integer;
    r1,r2,r3,r4,x1,x2,x3,x4,y1,y2,y3,y4:integer;
    cose,seno:integer;
    circ:array [1..4] of pointer;

begin
     video_mode ( $13);
     initvirt;

     inittables;

     loadpcx ('circlede.pcx',vp[1]);
     cls (0,vp[2]);
     cls (0,vga);

{     for a:=0 to 255 do setcolor (a,a div 4,a div 4, a div 4);}

     x:=160;
     y:=100;
     r1:=25 div 2;
     r2:=60 div 2;
     r3:=85 div 2;
     r4:=145 div 2;

     getimage (200,0,225,25,circ[1],vp[1]);
     getimage (250,0,310,60,circ[2],vp[1]);
     getimage (220,100,305,185,circ[3],vp[1]);
     getimage (0,0,145,145,circ[4],vp[1]);

     Deg:=1100;
     add:=10;

     repeat

     deg:=deg+add;
     repeat if deg>1269 then deg:=deg-1269 until deg<1269;
{     add:=add+1;}

     x1:=r3*Sines^[Deg] div 100;
     y1:=r3*Cosines^[Deg] div 100;

{       y1:=round(r1*sqrt(1-(x1 div r1)*(x1 div r1)));}
{       y1:=round(sqrt(r3*r3-x1*x1));}

       x2:=-x1;
       x3:=y1;
       x4:=-y1;
       y2:=-y1;
       y3:=-x1;
       y4:=x1;

     putimage_bob(x-r1,y-r1,0,circ[1],vp[2]);
     putimage_bob(x-r3,y-r3,0,circ[3],vp[2]);
     putimage_bob(x-r4,y-r4,0,circ[4],vp[2]);
     putimage_bob(x+x1-r2,y+y1-r2,0,circ[2],vp[2]);
     putimage_bob(x+x2-r2,y+y2-r2,0,circ[2],vp[2]);
     putimage_bob(x+x3-r2,y+y3-r2,0,circ[2],vp[2]);
     putimage_bob(x+x4-r2,y+y4-r2,0,circ[2],vp[2]);

     blur_f(vp[2],vp[1]);

     move (mem[vp[1]:0],mem[vga:0],64000);

     cls (0,vp[1]);
     cls (0,vp[2]);

     if keypressed=true then c:=readkey;
     until c=#27;

     cleartables;
     closevirt;
     video_mode ( 03);
end.