uses crt,graph,fondimag,
  dos,soursime,carre,coul256,t256,mbouton;


const
 T320:word=320;
 t200:word=200;
 t100:word=100;
 T160:word=160;

type
matrice=array[1..3] of word;
composante=record
            R,V,B:0..63;
           end;


var
    image:array [1..20400] of {word;}byte;
    fichier:file of matrice;
	fichier2:file of word;
    math:matrice;
a,b,i,j,gd,gm,compte:integer;
x,y,p,q,r:real;
Xmax,Xmin,Ymax,Ymin:real;
csa:word;
formule:string[100];

    mnd:windowtypen;
    paletten:palettetypen;
    rgb:rgbpalettetypen;


 Tcolor:array[0..255] of composante;
 reg:registers;

  d1,d2:real;
  lx,ly:real;
  cpti,cptj:real;
  pasx,pasy:real;
  zmax:word;

  julia:boolean;



   compt:byte; {compteur couleur}

 type
  tab=array[1..64000] of byte;
  pointeur=^tab;
 var ptr1:pointeur;

procedure cree_palette;  {autre palette}
var i,j,k:word;
    pale:couleur;
begin
 for i:=1 to 33 do
 with pale[i] do
 begin
  r:=i div 2;
  v:=i ;
  b:=30+i;
 end;

 for i:=0 to 13 do
 with pale[i+33] do
 begin
  r:=25+i;
  v:=15+i;
  b:=15;
 end;




 for i:=0 to 33 do
 with pale[i+33+13] do
 begin
  r:=0;
  v:=30+i;
  b:=0;
 end;

 for i:=0 to 33   do
 with pale[i+66+13] do
 begin
  r:=i;
  v:=63;
  b:=0;
 end;

 for i:=0 to 33  do
 with pale[i+100+13] do
 begin
  r:=32+i;
  v:=63;
  b:=i;
 end;

 for i:=0 to 33 do
 with pale[i+132+13] do
 begin
  r:=63;
  v:=63;
  b:=30+i;
 end;

 ecrit_palette(pale);
end;





procedure dune;
begin
 mode_graph(3);
 writeln('MANDOS2 programme de fractale par j.RIO 1994');
 halt;
end;

 PROCEDURE aligne_coordonne(xm,ym:word);  forward;

 PROCEDURE initpaletten;
var n:integer;

begin
 for n:=0 to 15 do
  paletten.colors[n]:=n;
 paletten.colors[16]:=0;
  setpaletten(paletten);
  rgb.size:=255+1;
  rgb.setrgb(0,0,0,0);
  rgb.setrgb(1,63,63,63);
  for n:=2 to 255 do
  rgb.setrgb(n,32+round(31*sin(n/255*4*pi)),n div 4,32+
   round(16*cos(N/255*2*pi)));
  setrgbpaletten(rgb);
end;


procedure mhelp;    (*=*)
 var
 bfin,baba:bouton;

begin
 hide;
 getmem(ptr1,64000); move(mem[$a000:0],ptr1^,64000);
 setgraphmode(gm);
 initpinceau;
 pinceau;

 fenetre_locale(70,20,570,130,black);
 baba.init(60+140,60+200+10,200,60,'SORTIR POUR DOS');
 bfin.init(60+140,60+300+10,200,60,'RETOUR Calcule');
 SetTextStyle(defaultfont, HorizDir, 1);  setcolor(15);
 outtextxy(100,30,'Pendant l''execution :');
 outtextxy(110,40,'h pour elever a la haute resolution 640*480*256 ');
 outtextxy(110,50,'f pour stoper un calcule');
 outtextxy(110,60,'+/- pour augmenter diminuer le nombre d''itineration');
 outtextxy(110,70,'p pour faire tourner la palette de 256 coul');
 outtextxy(110,90,'Si un cadre est rate:apuyer sur le bouton');
 outtextxy(110,100,'droit sans relacher le gauche');
 {outtextxy(110,110,'Pour quitter:appuyer sur esc pendant un calcule');}
 fenetre_locale(70,150,570,180,black);
 outtextxy(110,160,'La haute resolution demande le standard VESA');
 shows;
 repeat
  if baba.b_run('s') then dune;
 until bfin.b_run('r');
 baba.done       ;
 bfin.done       ;
 hide;
 mode_graph($13);
 initpaletten;
 move(ptr1^,mem[$a000:0],64000);
 freemem(ptr1,64000);   donepinceau;
end;





Procedure rectangle(x1,y1,x2,y2,coul:word);
var i:word;
begin
 for i:=x1 to X2 do putpixeln13(i,y1,coul);
 for i:=x1 to X2 do putpixeln13(i,y2,coul);

 for i:=y1 to y2 do putpixeln13(x1,i,coul);
 for i:=y1 to y2 do putpixeln13(x2,i,coul);
end;

Procedure getstatus2;
begin
  getstatus;
  xpos:=xpos div 2;

end;



PROCEDURE simulekey(acsi:char);
var scanc:byte;
    reg:registers;
begin
 with reg do
 begin
  reg.ah:=$05;
  reg.cx:=ord(acsi);
  intr($16,reg);
 end;
end;

FUNCTION delimite_carre(ncoul:word;var hx,hy:integer):boolean; {celui-ci marche impecable}
var
cest_fait:boolean;
k:integer;
c:word;

  Procedure avant; {cette suite de petite function est tres souvent recopier}
  {par la suite avantage:ne prend pas plus de place en memoire depuis}
  {pascal 6 et... plus facile a manier qu'un partageur de tache}
  {Elle se servent du tableau image de l'unite Nelie}
  var i:integer;
  begin
   k:=1;
   hide;
   if hx<=xpos then
   for i:=hx to xpos do begin
						 image[k]:=getpixeln13(i,hy);
						 k:=k+1;
						 image[k]:=getpixeln13(i,ypos);
						 k:=k+1;
						end else
	for i:=hx downto xpos do begin
							  image[k]:=getpixeln13(i,hy);
							  k:=k+1;
							  image[k]:=getpixeln13(i,ypos);
							  k:=k+1;
							 end;

   if hy<=ypos then
   for i:=hy to ypos do begin
						 image[k]:=getpixeln13(hx,i);
						 k:=k+1;
						 image[k]:=getpixeln13(xpos,i);
						 k:=k+1;
						end else
   for i:=hy downto ypos do begin
							 image[k]:=getpixeln13(hx,i);
							 k:=k+1;
							 image[k]:=getpixeln13(xpos,i);
							 k:=k+1;
						   end;
   shows;
  end;


  Procedure apres;
  var i:integer;
  begin
   k:=1;
   hide;
   if hx<=oldx then
   for i:=hx to oldx do begin
						 putpixeln13(i,hy,image[k]);
						 k:=k+1;
						 putpixeln13(i,oldy,image[k]);
						 k:=k+1;
						end else
   for i:=hx downto oldx do begin
							 putpixeln13(i,hy,image[k]);
							 k:=k+1;
							 putpixeln13(i,oldy,image[k]);
							 k:=k+1;
							end;

   if hy<=oldy then
   for i:=hy to oldy do begin
						 putpixeln13(hx,i,image[k]);
						 k:=k+1;
						 putpixeln13(oldx,i,image[k]);
						 k:=k+1;
						end else
   for i:=hy downto oldy do begin
							 putpixeln13(hx,i,image[k]);
							 k:=k+1;
							 putpixeln13(oldx,i,image[k]);
							 k:=k+1;
						   end;
   shows;
  end;

begin
 cest_fait:=false; getstatus2; c:=getpixeln13(xpos,ypos);
 shows;
 repeat
  getstatus2;
  if moved then
  begin
   hide;
   putpixeln13(oldx,oldy,c);
   c:=getpixeln13(xpos,ypos);
   putpixeln13(xpos,ypos,ncoul);
   shows;
  end;
  if pressleft  then
  begin
   hx:=xpos; {centre du carre}
   hy:=ypos;
   avant;
   while
		 (pressleft or oldleft) do begin
									 getstatus2;
                                     if right then
                                     begin
                                      apres;  cest_fait:=false;
                                      break;
                                     end;
                                     cest_fait:=true;
									 if (xpos<>oldx) or (ypos<>oldy)
                                     then begin
														   apres;
														   avant;
                                                           hide;
															rectangle(hx,
															hy,
															xpos,
															ypos,ncoul);
                                                            shows;
														  end;
									end;
  end;
  until (cest_fait) or (pressright);
  if cest_fait then
  begin
   hide;
   apres;
   shows;
   delimite_carre:=true;
  end else delimite_carre:=false;
end;   {delimite_carre, vrai si un cadre est trace}







PROCEDURE incpalette; forward;





PROCEDURE coordonne;
var
echange:real;
begin
 clrscr;
 writeln('Entre Xmin :');
 writeln('Entre Xmax :');
 writeln('Entre Ymin :');
 writeln('Entre Ymax :');
 writeln;
 writeln('Ce qui precede correspond aux coordonnees de l''ecran');
 writeln('Mandelbrot correspond a xmin=-2 xmax=2');
 writeln('                        ymin=-1 ymax=1');
 writeln('Plus tard pendant le tracer vous pourrais avoir accet a l''AIDE');
 writeln('Par la lettre ''a''');
 writeln;
 writeln('POUR OBTENIR L''AIDE PENDANT LE CALCULE APPUYER SUR A');



 gotoxy(14,1); read(xmin);

 gotoxy(14,2); read(xmax);
 gotoxy(14,3); read(ymin);
 gotoxy(14,4); readln(ymax);

 if xmin>xmax then begin
                    echange:=xmin;
                    xmin:=xmax;
                    xmax:=echange;
                   end;

 if ymin>ymax then begin
                    echange:=ymin;
                    ymin:=ymax;
					ymax:=echange;
                   end;

end;


PROCEDURE decripte_pour_affiche(a,b:word);
var
ac,bc:real;
begin
 if vmode=$13 then putpixeln13(a,b,compt) else
 putpixeln(a,b,compt);
 {csa:=round(r) shl 1 ;
 if vmode=$13 then putpixeln13(a,b,csa) else
 putpixeln(a,b,csa);}
end;




PROCEDURE determine_boucle;
var
i,j,z:integer; a,b,s:real;
depx,depy,px,py:real;
label lbl4,lbl3,debut;


      procedure hreso;
      var i,j:word;
          a,b:real;
      begin
       hide;
       getmem(ptr1,64000); move(mem[$a000:0],ptr1^,64000);
       mode_vesa($101);
       initpaletten;
       for i:=0 to 319 do
       for j:=0 to 199 do
       begin
        barn(650,490,(i shl 1)-2,       (j*12) div 5,
                     (i shl 1),         (12*(j+1)) div 5,
                     ptr1^[i+320*j]);
       end;
       freemem(ptr1,64000);
       T320:=640;
       t200:=480;
       t100:=240;
       T160:=320;
       simulekey('&');
       aligne_coordonne(1,2);
       determine_boucle;
       T320:=320;
       t200:=200;
       t100:=100;
       T160:=160;
       simulekey('&');
       aligne_coordonne(1,2);
       repeat getstatus; until (keypressed) or (left or right);
       mode_graph($13);
       initpaletten;
       if keypressed then readkey;
      end;



PROCEDURE choix_couleur;
begin
 csa:=round(r) shl 1 ;
end;


begin
 {en fonction de xmax et ymax on doit calculer sur 640480}
 {ex xmax=1, xmin=-1 calcule sur 2/640 point..}
  debut:
  cpti:=xmin;

  if julia then
     begin
      px:=d1;     py:=d2;
     end else
     begin
      depx:=d1; depy:=d2;
     end;

  for i:=0 to t320 do
  begin
   cptj:=ymin;
   for j:=0 to t200 do
   begin

    if julia then
     begin
      depx:=cpti; depy:=cptj;
     end else
     begin
      px:=cpti;
      py:=cptj;
     end;

	x:=depx; y:=depy; r:=sqr(x)+sqr(y); compt:=0;
	for z:=0 to zmax do
					   begin
						 s:=x;
                         x:=r-2*sqr(y)+px;
						 {x:=sqr(x)-sqr(y)+cpti;}
						 y:=2*s*y+py;
						 r:=sqr(x)+sqr(y); inc(compt);
						 if r>=4 then {goto lbl4;}
                         break;
						end;
	 lbl4:
				   {choix_couleur;}
                   if keypressed then begin
                                       case readkey of
                                        '+':inc(zmax);
                                        '-':if zmax>1 then dec(zmax);
                                        'p':incpalette;
                                        'h':if vmode<>$101 then
                                            begin
                                             hreso;
                                             goto debut;
                                            end;
                                        'f':exit;
                                        'a':mhelp;
                                        #27:dune;
                                       end;
                                      end;

				   decripte_pour_affiche(i,j);  {decripte_pour_affiche(a,-b);}
	 {lbl4:}
    cptj:=cptj+pasy;
   end;
   cpti:=cpti+pasx;
  end;

end;



PROCEDURE aligne_coordonne(xm,ym:word);

                  Procedure agrandie(xn,yn:word);
                   var i,j,c:integer;
                       a,b:real;
                   begin
                    xpos:=xpos-xn; ypos:=ypos-yn;
                    for j:=0 to ypos do
                    for i:=0 to xpos do
                    begin
                     c:=ptr1^[xn+i+(yn+j)*320];
                     barn(640,480,(t160*((i shl 1)-3)) div (xpos),
                                  (j*t200) div (ypos),
                                  (t160*((i shl 1)-1)) div (xpos),
                                  (j*t200+t200) div (ypos),c);
                    end;
                   end;

                   (*Procedure agrandie(xn,yn:word);
                   var i,j,c:integer;
                       a,b:real;
                   begin
                     xpos:=xpos-xn; ypos:=ypos-yn;
                     a:=t320/(xpos);
                     b:=t200/(ypos);
                    for j:=0 to ypos do
                    for i:=0 to xpos do
                    begin
                     c:=ptr1^[xn+i+(yn+j)*320];
                     barn(640,480,round(i*a-a-(a/2)),round(j*b),
                                  round(i*a-(a/2)),round(j*b+b),c);
                    end;
                   end;             *)

 begin
   lx:=abs(xmax-xmin);
  ly:=abs(ymax-ymin);
  pasx:=lx/t320;
  pasy:=ly/t200;
  if keypressed then if readkey='&' then exit;
  hide;

  getmem(ptr1,64000); move(mem[$a000:0],ptr1^,64000);
  mode_graph(3);
  writeln('xmin=',xmin,'xmax ',xmax);
  writeln('ymin=',ymin,'ymax ',ymax);  readkey;
  mode_graph($13);
  initpaletten;
  move(ptr1^,mem[$a000:0],64000);
  if x<>0 then agrandie(xm,ym);
  shows;
  freemem(ptr1,64000);
 end;



PROCEDURE initpaletten1;
var n:integer;

begin
 for n:=0 to 15 do
  paletten.colors[n]:=n;
 paletten.colors[16]:=0;
  setpaletten(paletten);
  rgb.size:=255+1;
  rgb.setrgb(0,0,0,0);
  rgb.setrgb(1,63,63,63);
  for n:=2 to 255 do
  rgb.setrgb(n,
  n,n,n);
  setrgbpaletten(rgb);
end;


PROCEDURE incpalette;
var
n:integer;
cv:colorvalue;

begin
 cv:=rgb.colors[255];
 for n:=maxcolors-1 downto 2 do rgb.colors[n+1]:=rgb.colors[n];
 rgb.colors[2]:=cv;
 setrgbpaletten(rgb);
end;


PROCEDURE zmoo;
var x,y,c:integer;
label la;
begin
 shows;

 repeat
  repeat
   shows; if keypressed then if readkey=#27 then begin mode_graph(3); exit; end;
  until delimite_carre(random(256),x,y);
  if (abs(xpos-x)<=3) and (abs(ypos-y)<=3) then
  begin
   d1:=xmin+xpos*pasx;     d2:=ymin+ypos*pasy;
   julia:=true;
   goto la;
  end;
  xmax:=xmin+xpos*pasx;
  xmin:=xmin+x*pasx;
  ymax:=ymin+ypos*pasy;
  ymin:=ymin+y*pasy;
  aligne_coordonne(x,y);
  la:
  hide;
  determine_boucle;
  shows;
 until true=false;
end;

{$l c:\bp\bin\egavga.obj}
procedure jvgadrv; external;

PROCEDURE lie_graf;

begin
 {pas mal trouve ce truc pour transforme une procedure en pointeur !}
 if RegisterBGIdriver(@jvgadrv) < 0 then
 begin
   WriteLn('Il y a eu un petit problem: ',GraphErrorMsg(GraphResult));
   Halt;
 end;
 Gd := Detect;
 InitGraph(Gd, Gm,' ');
 if GraphResult <> grok then
  Halt(1);
end;


BEGIN
 julia:=false;
 zmax:=67;
 assign(fichier,'f1.dat');
 formule:='';
 clrscr;
 writeln('Ce que vous entrer correspond au premier therme des suites');
 writeln('qui vont engendrer une fractale');
 writeln('Pour obtenir mandelbrot: x0=0 y0=0');
 write('Entre x0: '); readln(d1);
 write('Entre y0: '); readln(d2);

 coordonne;

 aligne_coordonne(0,0);

 lie_graf;
 mode_graph($13);
 initpaletten;
 csa:=cyan;

 hide;
 getstatus2;
 determine_boucle;
 zmoo;
 dune;
END.