{$A-,G+,N+,E+}
Program Fatu;
Uses Crt,DOS;
Const
xmax=320;
ymax=200;
coord:array[1..4] of char='xyuv';
setcoord: set of char=['X','Y','U','V'];
a:extended=-0.0013;
b:extended=-0.25;
k:word=256;
epsilon:extended=0.09;
{m:array[1..4] of extended=(,9,.9,.9,.9);}
kxy:array[0..1] of byte=(1,2);
xy1:array[0..1] of extended=(-1.53,-1.53);
xy2:array[0..1] of extended=(1.53,1.53);

Var

counter,index          :word;
attr,oldc,nc           :byte;
save,m,t               :array[1..4] of Extended;
xs,ys,f                :Extended;
{xy1,xy2:array[0..1] of extended;}
g,n,af,ac              :Byte;
{kxy:array[0..1] of byte;}
sx,sy,nk               :word;
c                      :Char;
Buf                    :array[0..62535] of byte;
fln                    :namestr;
mf                     :file;
path                   :pathstr;
fl                     :searchrec;






Procedure Zap; BEGIN
   t[3]:=b*t[3]+Sqr(t[1])-Sqr(t[2]);
   t[4]:=b*t[4]+2*t[1]*t[2];               { t[1..4]=[x y z t] }
   t[1]:=a*t[1]+Sqr(t[3])-Sqr(t[4]);
   t[2]:=a*t[2]+2*t[3]*t[4]
                END;


procedure input (m:string;var n:extended);
BEGIN
   repeat write('Enter ',m);{$i-}readln(n);{$i+} until ioresult=0
END;



function inkey:char;
var c:char;
label again;
BEGIN
again:
   c:=readkey;if c=chr(0) then begin c:=readkey;goto again end;
   if c>='a' then byte(c):=byte(c)-32;
   inkey:=c
END;




procedure d(i:word);
label k;
BEGIN
Writeln('The  ',coord[i],'  coordinate.');
Write('Press F for FIXED, C for CHANGING state...');
K:
c:=inkey;
case c of
   'F':begin
   if af=2 then goto k else af:=af+1;
   writeln('  FIXED.');
   input('Enter fixed coordinate '+coord[i]+':',m[i]);
   end;
   'C':begin
   if ac=2 then goto k;
   writeln('  CHANGING.');
   kxy[ac]:=i;
   input('Enter starting '+coord[i]+':',xy1[ac]);
   input('Enter ending '+coord[i]+':',xy2[ac]);ac:=ac+1
   end;
else
   goto k
end
END;



function distance:extended;
begin
   distance:=sqrt(t[1]*t[1]+t[2]*t[2]+t[3]*t[3]+t[4]*t[4])
end;



procedure waitenter;assembler;
asm
 @s:mov ah,0;int 16h;cmp al,13; jne @s
end;




procedure installdiap;
begin
m[kxy[0]]:=xy1[0];
m[kxy[1]]:=xy1[1];
end;


procedure store(x:byte);
begin
buf[index]:=x;inc(index)
end;



function getpixel(x,y:integer):byte;
var c:byte;
begin
asm
   mov ah,0Dh
   mov cx,x
   mov dx,y
   int 10h
   mov c,al
end;
getpixel:=c
end;




procedure storescreen;
begin
counter:=0;oldc:=abs(getpixel(0,0)-8);index:=114;
for sy:=0 to ymax-1 do
for sx:=0 to xmax-1 do begin
nc:=getpixel(sx,sy);
if (nc<>oldc) or (counter=255) then if (oldc=255) or (counter>4) then begin
           store(255);
           store(oldc);
           store(counter);
           counter:=0;oldc:=nc   end
            else
                 for n:=1 to counter do store(oldc);
inc(counter);
                       end
end;{storescreen}


function error:boolean;
var n:word;
begin
n:=ioresult;
if n<>0 then begin
writeln('  *** Error ',n,' ***');error:=true end
else error:=false
end;





procedure sav;
begin
textmode(co80);
write('Enter filename to save : ');readln(fln);
move(k,buf[0],2);
move(a,buf[2],10);
move(b,buf[12],10);
move(epsilon,buf[22],10);
move(kxy,buf[32],2);
move(xy1,buf[34],20);
move(xy2,buf[54],20);
move(m,buf[74],40);{ 74+40=114 - the beginning of stored screen }
assign(mf,fln);
{$i-}
rewrite(mf,1);
if error then exit;
blockwrite(mf,buf,index+1,counter);
if counter<>0 then begin writeln (' *** Error ',counter,' ***');exit end;
close(mf);
if error then exit;
{screenout}

end;{save}


procedure load;
label start;
begin
start:
write('Enter filename or @@ for exit : ');readln(fln);
if fln='@@' then exit;
assign(mf,fln);
{$i-}
reset(mf);
if error then goto start;




end;{load}



procedure files;
begin
writeln(path);
attr:=readonly+archive;
{$i-}
findfirst({path+}'*.fat',attr,fl);
while {$i+} doserror=0   {$i-} do begin
    writeln('   ',fl.name);
    c:=inkey;  if c=chr(27) then break;
    findnext(fl)
end;
{$i-}
load
end;{files}


procedure cd;
var sp:pathstr;
begin
writeln(' Current directory :');
writeln(path);
writeln;      sp:=path;
write('Enter new path : ');readln(path);
{$i-}
chdir(path);
if error then path:=sp
end;





{--------------------------------320*200------------------------------------------------}
Procedure fatumain;
BEGIN
asm
   mov ah,00
   mov al,13h
   int 10h                  { GrMode 13h, Page 00 }
   mov ah,05
   mov al,0
   int 10h
end;
xs:=(xy2[0]-xy1[0])/xmax;ys:=(xy2[1]-xy1[1])/ymax;
INSTALLDIAP;
save:=m;
For sx:=0 to xmax-1 do BEGIN
   m[kxy[0]]:=m[kxy[0]]+xs;M[KXY[1]]:=SAVE[KXY[1]];
   asm
      mov al,0
      mov ah,01
      int 16h
      mov n,al               { If  Enter  pressed then exit }
   end;
   if n=13 then Break;
   For sy:=0 to ymax-1 do BEGIN
      m[kxy[1]]:=m[kxy[1]]+ys; t:=m;
      For nk:=1 to k do    BEGIN
         Zap; F:=distance; if f>1000 then break;
         If F < Epsilon
                                               Then  BEGIN
                                                           n:=nk mod 256;
                                                           Asm
                                                              mov bh,00
                                                              mov ah,0ch
                  { Put Pixel(sx,sy,n) }                      mov al,n
                                                              mov cx,sx
                                                              mov dx,sy
                                                              int 10h
                                                           end;
                                                           Break
                                                           END
                          END
                       END
                    END;
           storescreen;
           repeat
           repeat c:=inkey until not keypressed;
           if c='S' then {begin} sav{;waitenter}{;break end};
           until c=chr(13);
   m:=save
END;





function inkey_xyzt:byte;
var c:char;n:byte;
begin

   repeat c:=inkey;until c in setcoord;
   for n:=1 to 4 do if c=upcase(coord[n]) then inkey_xyzt:=n
end;





procedure fatu80_25;
begin
   textmode(co80);
   xs:=(xy2[0]-xy1[0])/80;ys:=(xy2[1]-xy1[1])/25;INSTALLDIAP;save:=m;
   for sx:=1 to 79 do BEGIN
      m[kxy[0]]:=m[kxy[0]]+xs;M[KXY[1]]:=SAVE[KXY[1]];
      asm mov al,0; mov ah,1; int 16h; mov n,al end;
      if n=13 then break;
      for sy:=1 to 25 do BEGIN
         m[kxy[1]]:=m[kxy[1]]+ys; t:=m;
         for nk:=1 to k do begin zap;f:=distance;
         if f>1000 then break;
         if f < epsilon then begin
         gotoxy(sx,sy);textbackground(nk mod 16);
         textcolor ((nk+4) mod 16);write(chr(nk div 16 +48));break end end
                         END
                      END;
            WaitEnter;
            M:=SAVE;
end;



procedure show;
BEGIN
repeat
textmode(co80);textcolor(white);
clrscr;writeln(
'                   1. Files'#13#10+
'                   3. Change Directory'#13#10+
'                   5. Load'#13#10+
'                   ESC : Exit');
c:=inkey;
case c of
   '1':files;
   '3':cd;
   '5':load;
   chr(27):exit
end
until false
END;


procedure inpdiap(m:byte);
begin
input('starting '+coord[n]+' : ',xy1[m]);
input('ending '+coord[n]+' : ',xy2[m])
end;



procedure inpfixed;
begin
input(coord[n]+' : ',m[n])
end;




procedure build;
BEGIN
repeat
textmode(co80);textcolor(white);textbackground(black);
clrscr;
writeln(
'                 7. Define all coordinates'#13#10+
'    X / Y / U / V  :  Define fixed coordinates or diapazones'#13#10+
'    A / B / E / I  :  Define Alpha / Beta / Epsilon / amount of iterations'#13#10+
'    Space : Quick building     ESC : Exit'#13#10+
'    TAB : 320*200, 256 colors; press  S  to save the picture');

writeln(
'                             *** Fixed ***');
for n:=1 to 4 do
   if (kxy[0]<> n)  and (kxy[1]<> n) then write('   ',coord[n],' = ',m[n]);
   writeln;
writeln(
'                          *** Diapazones ***');
writeln(
xy1[0],' < ',coord [kxy[0]],' < ',xy2[0]);
writeln(
xy1[1],' < ',coord [kxy[1]],' < ',xy2[1]);
writeln('               Alpha      = ',a);
writeln('               Beta       = ',b);
writeln('               Epsilon    = ',epsilon);
writeln('               Iterations = ',k);



c:=inkey;
case c of
   '7':begin
       ac:=0;af:=0;for n:=1 to 4 do d(n)
       end;
   'A':input('Alpha : ',a);
   'B':input('Beta : ',b);
   'E':input('Epsilon : ',epsilon);
   'I':begin
       repeat       input('amount of iterations : ',f)
       until (f>0) and (f<65536);
       k:=round(f)
       end;
   ' ':fatu80_25;
   chr(9):fatumain;
   chr(27):exit
end;
if c in setcoord then for n:=1 to 4 do
   if  upcase(coord[n])=c then
       if n=kxy[1] then inpdiap(1)
       else if n=kxy[0] then inpdiap(0) else inpfixed;
until false

END;



{--------------------------------Main--------------------------------------------}

BEGIN
CheckBreak:=False;
M[1]:=0;M[2]:=0;M[3]:=0;M[4]:=3.60;
repeat
TextMode(co40);TextColor(white);textbackground(black);Clrscr;
gotoxy(1,1);write(
'           1. Show'#13#10+
'           3. Build new picture'#13#10+
'           5. Exit program');
c:=inkey;
case c of
   '1' : Show;
   'S' : show;
   '3' : build;
   'B' : Build;
   '5' : exit;
   'E' : exit
   end
until false






END.





{-----------------------------------------------------------------------------------}