{$A-,G+,N+,E+,M 32768,0,0}
Program Fatu;
Uses Crt,DOS;
Const
nfiles=2048;
msg:array[1..34] of char='FATOUR domain section.{Gleb Belov}';
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);

type
     ht=array[1..1024] of byte;

Var
err                    :boolean;
index,findex           :word;
attr,oldc,nc,counter   :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;}
nk,h,wm                :word;
c                      :Char;
Buf                    :array[0..64000] of byte;
hbuf                   :array[0..64250 div 1024] of ht absolute buf;
fln                    :pathstr;
mf                     :file of ht;
path                   :pathstr;
fl                     :searchrec;
sx,sy                  :integer;



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);
var k:byte;
BEGIN
   repeat
{   for k:=1 to 6+length(m) do write(' ');write(n:10,#13);}
   write('Enter ',m);{$i-}
   textbackground(black);readln(n);textbackground(blue){$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;
      if c=chr(72) then begin inkey:=chr(0);exit end;
      if c=chr(80) then begin inkey:=chr(1);exit end;
      if (c=chr(73)) or (c=chr(75)) then begin inkey:=chr(2);exit end;
      if (c=chr(77)) or (c=chr(81)) then begin inkey:=chr(3);exit end;
      goto again end;
   if c>='a' then byte(c):=byte(c)-32;
   inkey:=c
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 waitesc;assembler;
asm
 @s:mov ah,0;int 16h;cmp al,27; 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 bh,0
   mov cx,x
   mov dx,y
   int 10h
   mov c,al
end;
getpixel:=c
end;



procedure s(mode:byte);
begin
textmode(mode);textbackground(blue);textcolor(white);clrscr
end;



procedure storescreen;
label n;
begin
counter:=0;oldc:=getpixel(0,0);if oldc=255 then oldc:=4;index:=249;
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 begin
   store(oldc);store(counter);counter:=0;oldc:=nc;if index=63997 then goto n;
                                     end;
inc(counter)
                       end;
n:
store(oldc);store(counter)
end;{storescreen}


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



procedure curd;
begin
{$i-}writeln(' ',path)
end;

procedure putpixel(c:byte);
begin
mem[$a000:word(sx)+320*word(sy)]:=c
end;
(* assembler;
                                                        Asm
                                                              mov bh,00
                                                              mov ah,0ch
                  { Put Pixel(x,y,color) }                    mov al,c
                                                              mov cx,sx
                                                              mov dx,sy
                                                              int 10h
                                                           end;      *)



procedure get(var n:byte);
begin
n:=buf[index];inc(index)
end;


Procedure GrMode(n:byte);assembler;
asm
   mov ah,00
   mov al,13h
   or al,n
   int 10h                  { GrMode 13h, Page 00 }
   mov ah,05
   mov al,0
   int 10h
end;




procedure grwrite(x,y,c:byte;s:string);
var k,m:byte;
procedure puts(k,x,y,c:byte;v:char);assembler;
asm
   mov ah,2
   mov bh,0
   mov dl,k
   mov dh,y
   int 10h
   mov ah,9
   mov al,v
   mov bl,c
   mov cx,1
   int 10h
end;

begin
k:=x;for m:=1 to 13 do if s[m]<>' ' then begin puts(k,x,y,c,s[m]);inc(k) end
end;


procedure writeparams;
var h:string[13];j:byte;
begin
str(a:7:4,h);
grwrite(5,23,15,'Alpha='+h);
str(b:7:4,h);
grwrite(22,23,15,'Beta='+h);
j:=5;
for n:=1 to 4 do if (n<>kxy[1]) and (n<>kxy[0]) then begin
str(m[n]:11:4,h);
grwrite(j,24,15,upcase(coord[n])+'='+h);j:=22
              end;
end;


procedure toscreen;
BEGIN
grmode(128);
index:=249;counter:=0;
for sy:=0 to ymax-1 do
for sx:=0 to xmax-1 do BEGIN
if counter=0 then begin
   get(nc);get(counter)
                   end;
dec(counter);putpixel(nc)

                        END;if not keypressed then writeparams else  begin
                        while keypressed do c:=inkey;if c<>chr(13) then
                        writeparams end
END;




procedure sav;
begin
gotoxy(1,24);insline;insline;
write('Enter filename to save : ');readln(fln);
if fln='' then exit;
fln:=fln+'.fat';

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=249 - the beginning of stored screen }

move(msg,buf[114],35);
assign(mf,fln);
{$i-}
rewrite(mf);
if error then exit;
for nk:=0 to index div 1024 do begin write(mf,hbuf[nk]);
           n:=ioresult;if n<>0 then  begin
           write(' *** Writing error ',n,' ***');close(mf);exit  end
              end;
close(mf);
end;{save}




procedure load;
begin
if fln='' then begin gotoxy(1,24);insline;insline;
write('Enter filename to load : ');readln(fln);
if fln='' then exit;fln:=fln+'.fat'
                end;
assign(mf,fln);
{$i-}
reset(mf);
if error then exit;
index:=filesize(mf);if index>64000 div 1024 then index:=64000 div 1024;
for nk:=0 to index do begin read(mf,hbuf[nk]);
     n:=ioresult;if (n<>0) and (n<>100) then begin
     write(' *** Reading error ',n,' ***');close(mf);exit end
                 end;
close(mf);

move(buf[0],k,2);
move(buf[2],a,10);
move(buf[12],b,10);
move(buf[22],epsilon,10);
move(buf[32],kxy,2);
move(buf[34],xy1,20);
move(buf[54],xy2,20);
move(buf[74],m,40);{ 74+40=249 - the beginning of stored screen }


toscreen


end;{load}




procedure cd;
begin
gotoxy(1,24);
write('Enter new path : ');readln(path);
{$i-}
chdir(path);
if error then ;getdir(0,path)
end;





{--------------------------------320*200------------------------------------------------}

procedure fatumain;
label n,j;
BEGIN
GrMode(0);
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]];
   if keypressed then
   if readkey=chr(27) then goto j;
   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 begin {putpixel(round(ln(nk)) mod 256);}goto n end;
         If F < Epsilon
                                               Then  BEGIN
                                                           putpixel(byte(nk));
                                                           goto n
                                                     END
                          END;
                 n:    END
                    END;
           j:
           storescreen;

   m:=save
END;






procedure fatu80_25;
label n;
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]];
      if keypressed then
      if readkey=chr(27) then begin m:=save;exit end;
      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 goto n;
         if f < epsilon then begin
         gotoxy(sx,sy);textbackground(nk mod 16);
         textcolor ((nk+4) mod 16);write(chr(nk div 16 +48));goto n end end;
         n:                END
                      END;
            WaitESC;
            M:=SAVE;
end;

PROCEDURE Show;
VAR
   ss:word;
   type
   tfiles=array[1..nfiles] of record
                              name:string[8];
                              size:longint;
                              end;
VAR
   files:tfiles;
   nm:string[12];
   n1:array[0..12] of byte ABSOLUTE nm;
   n,k:byte;
   ms,findex:word;




procedure placefile;
begin
gotoxy(3,wherey);textbackground(blue);
write(files[ss].name);gotoxy(11,wherey);
write(files[ss].size:8)
end;



procedure tos;
procedure mw(s:string);
begin
gotoxy(25,wherey);writeln(s)
end;
begin
textbackground(green);gotoxy(1,1);
{write(
'     Enter-load 1.Save 3.Load filename 5.ChDir Space-ReRead 7.Demo 9.Help       ');
}
textbackground(red);curd;
textbackground(green);
gotoxy(4,2);write('Name');
gotoxy(13,2);writeln('Size'#10);
mw('              Enter-Load Space-ReRead              ');
mw(' 1.Save 3.Load filename 5.ChDir 7.Demo from cursor '#10);
textbackground(black);
mw('You can work only with *.FAT files.');
mw('Chosen Demo, you will see all pictures starting');
mw('from the file under cursor.');
mw('Press ESC to interrupt demo,');
mw('any other key to load next.');
mw('After loading all the parameters are left in memory,');
mw('choose "Build new picture" item.')
end;



procedure demo;
var k:byte;
begin
{ss:=ms+n;
attr:=archive+hidden+readonly+sysfile;
findfirst('*.fat',attr,fl);
while doserror=0 do begin
if k=0 then if fl.name=files[ss].name+'.FAT' then k:=1;
if k=1 then begin
fln:=fl.name;}
for wm:=ms+n to findex do begin fln:=files[wm].name+'.fat';
load;while keypressed do c:=inkey; if err then begin
              s(co80);writeln(#10#10#10+
              ' Loading error ( ',fln,' ). Press any key to continue or ESC to exit...');
              end;
              c:=inkey;if c=chr(27) then exit {;findnext(fl)}
                     end
end;



procedure r(n:byte);assembler;
asm
   mov ah,n
   mov al,1
   mov bh,0
   mov bl,0fh
   mov cl,1
   mov ch,2
   mov dl,19
   mov dh,22
   int 10h
end;

procedure paste(k,c:byte);assembler;
asm
   mov dh,k
   mov dl,1
   mov bh,0
@l:
   mov ah,2
   int 10h
   mov ah,8
   int 10h
   mov ah,9 {0ah}
   mov bl,c
   mov bh,0
   mov cx,1
   int 10h
   inc dl
   cmp dl,19
   jne @l
end;


procedure cur(m:byte);
begin
paste(m+2,$1f);
paste(n+2,$70)
end;

procedure rollup;
begin
if ms=1 then exit else begin dec(ms);ss:=ms;r(7);placefile;cur(1) end
end;


procedure curup;
begin
dec(n);cur(n+1)
end;


procedure rolldown;
begin
if ms+20=findex then exit else begin inc(ms);ss:=ms+20;r(6);placefile;cur(19) end
end;

procedure curdown;
begin
if ms+n<findex then begin inc(n);cur(n-1)end;
end;







function menu:char;
label j;
BEGIN
s(co80);textbackground(black);clrscr;tos;
for ac:=0 to 20 do begin
if ac+ms>findex then goto j;
gotoxy(15,ac+3);
ss:=ms+ac;
placefile
end;
j:
cur(n);
repeat
gotoxy(1,26);
c:=inkey;
case c of
   chr(0): if n=0 then rollup else curup;
   chr(1): if n=20 then rolldown else curdown;
else
   if c in [{chr(2),chr(3),}chr(13),chr(27),' ','1','3','5','7','9'] then begin menu:=c;{normcursor}exit end
end;
until false
END;





procedure readfiles;
begin
files[1].name:='';
attr:=hidden+sysfile+readonly+archive;
findfirst('*.fat',attr,fl);
while (doserror=0) and (findex<=nfiles) do begin
   inc(findex);
   nm:=fl.name;n1[0]:=n1[0]-4;
      files[findex].name:=nm;
      files[findex].size:=fl.size;
findnext(fl)
                     end
end;






{procedure show;}
label l1,l2;
BEGIN
l1:
s(co80);
tos;
findex:=0;ms:=1;n:=0;
readfiles;
getdir(0,path);
l2:
    c:=menu;
case c of
   chr(27):exit;
   '1':begin sav;goto l1 end;
   {chr(13)}
   '3':begin fln:='';load;if err then c:=inkey else waitesc end;
   '5':begin cd;goto l1 end;
   '7':demo;
   {'9':help;}
      chr(13):begin ss:=ms+n;
   fln:=files[ss].name+'.fat';load;waitesc  end;
   chr(2):begin ms:=ms-19;if ms<1 then ms:=1;goto l2 end;
   chr(3):begin ms:=ms+19;if ms+20>findex then ms:=findex-20;
   if ms<1 then ms:=1;goto l2 end;
   chr(32):goto l1
end;
goto l2
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 define;
var k,k2:byte;
    xy:array[0..1] of byte;
VAR      v1:array[0..1] of extended;
         v2:array[0..1] of extended;
label j;
begin
writeln(' Press  F  for fixed,  C  for changing state...');
ac:=0;af:=0;
for n:=1 to 4 do begin
write(' Coordinate ',upcase(coord[n]),' : ');
repeat
c:=inkey
until (c='F') or (c='C') or (c=chr(27));
case c of
   'F':begin inc(af);writeln('FIXED.') end;
   'C':begin xy[ac]:=n;inc(ac);writeln('CHANGING.') end;
   chr(27):exit
end;
if ac = 2 then goto j;
if af = 2 then begin
   if ac=1 then xy[1]:=4 else begin xy[0]:=3;xy[1]:=4 end;
   goto j         end;
end;
j:
     for k:=0 to 1 do begin  v2[k]:=xy2[k];v1[k]:=xy1[k] end;
k:=0;
for n:=1 to 4 do begin
if n=xy[k] then begin
   if xy[k]=kxy[abs(k-1)] then begin
                            xy1[k]:=xy1[abs(k-1)];
                            xy2[k]:=xy2[abs(k-1)]
                                end
                          else
        if xy[k]<>kxy[k] then begin
                         xy1[k]:=m[n]-1;
                         xy2[k]:=m[n]+1
                               end;
        inc(k);if k>1 then k:=1    end
   else
      for k2:=0 to 1 do
      if n=kxy[k2] then m[n]:=(v1[k2]+v2[k2])/2
end;
for k:=0 to 1 do kxy[k]:=xy[k];
end;

procedure build;
BEGIN
repeat
s(co80);writeln;
writeln(
'                 D. Define fixed & changing 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    TAB : 320*200');
writeln(#10+
'                  Building section along the plane ',upcase(coord[kxy[0]]),upcase(coord[kxy[1]]));
writeln(#10+
'                             *** Fixed ***');write(' ');
for n:=1 to 4 do
   if (kxy[0]<> n)  and (kxy[1]<> n) then write('   ',coord[n],' = ',m[n]);
writeln(#13#10+
'                          *** Diapazones ***'#10);
writeln('        ',
xy1[0],' < ',coord [kxy[0]],' < ',xy2[0]);
writeln('        ',
xy1[1],' < ',coord [kxy[1]],' < ',xy2[1],#10#10);
writeln('                         Alpha      = ',a);
writeln('                         Beta       = ',b);
writeln('                         Epsilon    = ',epsilon);
writeln('                         Iterations =  ',k);



c:=inkey;
case c of
   'D':Define;
   '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;


procedure helpmain;
begin
s(co80);
writeln('To understand the problem completely, read the files REPORT .');
writeln('program builds intersections of the Fatour domain iterating the mapping');
writeln(' F(z,w)=(Az+(Bw+z^2)^2;Bw+z^2), where {|A|;|B|}<=1;');
writeln('z=x+iy;w=u+iv (i^2=-1).');
writeln('The plane of intersection is got by fixing some two of the four coordinates');
writeln(' X,Y,U,V and defining diapazones for other two.');
writeln
end;



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

BEGIN
CheckBreak:=False;
M[1]:=0;M[2]:=0;M[3]:=0;M[4]:=3.60;
{fsplit(paramstr(0),mydir,fln,fln);}
getdir(0,path);
repeat
s(co40);
gotoxy(1,11);writeln(
'           1. Work with files'#13#10+
'           3. Build new picture'#13#10+
'           5. Show last picture'#13#10+
'           7. Help'#13#10+
'           9. Exit program');
c:=inkey;
case c of
   '1' : Show;
   'W' : show;
   '3' : build;
   'B' : Build;
   '5' : begin toscreen;waitesc end;
   '7' : helpmain;
   '9' : exit;
   'E' : exit
   end
until false






END.





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