unit fondimag;

                            interface
         {ceci est l'une de mes plus vieille unite}
         {elle offre divers truc graphic}
         {jpix:commande sophistique pour remplacer putpixel}
         {aff et scanimage ect}
uses graph,crt;

TYPE
echange_disk=array[1..5] of word;

 var
 couleur1,couleur2,size,i,j:word;
 c:pointer;
 ouix,nonx:boolean;
 fichier:file of echange_disk;
 math:echange_disk;

 procedure pinceau;
 PROCEDURE initpinceau;
 PROCEDURE donepinceau;
 PROCEDURE initpinceau2(c1,c2:word); {rajoue indispensable}
 PROCEDURE fenetre(couleur:word); {pour afficher une fenetre}
 PROCEDURE fenetre_locale(x1,y1,X2,Y2:integer;couleur:word);
 PROCEDURE grafic;   {pour se lancer en mode graphic}
 PROCEDURE scanimage(mot:string;corx1,corx2,cory1,cory2:word);
 PROCEDURE jpix(x,y:integer;couleur:byte);
 PROCEDURE affimage(mot:string);

							implementation
 uses dos;

PROCEDURE jpix(x,y:integer;couleur:byte);  assembler;
asm
 mov ax,y
 mov dx,80  {largeur de ligne}
 mul dx
 mov bx,x
 mov cl,bl

 shr bx,1
 shr bx,1
 shr bx,1
 add bx,ax

 and cl,7
 xor cl,7
 mov ah,1
 shl ah,cl

 mov dx,3ceh  {registre d'indexe du controleur g}
 mov al,8
 out dx,ax

 mov ax,(02h shl 8)+5
 out dx,ax

 mov ax,0a000h
 mov es,ax
 mov al,es:[bx]
 mov al,couleur
 mov es:[bx],al
 {retablissement des valeurs par defaut des registres}
 {mov ax,(0ffh shl 8) +8
 out dx,ax

 mov ax,(00h shl 8) +5
 out dx,ax}
end;

FUNCTION automatique:string;
var
 cheminbgi:string[64];
 fichier:text;

begin
 swapvectors;
  exec('c:\bp\travexe\cherbgi.exe',' ');
 swapvectors;
 assign(fichier,'tempo.txt');
 {$i-}
 reset(fichier);
 {$i+}
 if ioresult=0 then
 begin
  readln(fichier,cheminbgi);
  automatique:=cheminbgi;
  close(fichier);
  erase(fichier);
 end else automatique:=' ';
end;


 PROCEDURE grafic;
  var
 gogodrive,gogomode : Integer;
 minus:string[50];
begin
 gogodrive := Detect;
 write('Entre chemin complet pour mode graphique: ');
										readln(minus);
 if minus='' then minus:=automatique;
 InitGraph(gogodrive,gogomode ,minus);
 if GraphResult <> grOk then begin
                              writeln('desole, mauvais chemin pour mode graphic');
                              halt(1);
							 end;

 end;


 PROCEDURE fenetre_locale(x1,y1,X2,Y2:integer;couleur:word);
                        procedure effassse;
                        var
                        remplissage:FillSettingsType;
						begin
                         getfillsettings(remplissage);
                         setfillstyle(1,lightblue);
                         bar(x1-2,y1-2,x2+7,Y2+7);
                         with remplissage do setfillstyle(pattern,color);
                        end;

Begin {fenetre locale}
 {construction de l'illusion c'est a dire les sous cadres comme norton}
 effassse;
 setlinestyle(solidln,1,normwidth);
 setcolor(white);
 SetFillStyle(1,couleur);
 bar(round(X1+(X2-X1)*(40/100)),round(y1+(y2-y1)*(40/100)),
     round(X1+(X2-X1)*(60/100)),round(y1+(y2-y1)*(60/100)));
 rectangle(round(X1+(X2-X1)*(40/100)),round(y1+(y2-y1)*(40/100)),
     round(X1+(X2-X1)*(60/100)),round(y1+(y2-y1)*(60/100)));

 delay(70);
 effassse;
 bar(round(X1+(X2-X1)*(29/100)),round(y1+(y2-y1)/15),round(X1+(X2-X1)*(71/100)),
     round(y1+(y2-y1)*(14/15)));
 rectangle(round(X1+(X2-X1)*(29/100)),round(y1+(y2-y1)/15),round(X1+(X2-X1)*(71/100)),
     round(y1+(y2-y1)*(14/15)));
 delay(70);
 effassse;
 bar(round(X1+(X2-X1)*(1/7)),round(y1+(y2-y1)*(1/7)),round(X1+(X2-X1)*(6/7)),
     round(y1+(y2-y1)*(6/7)));
 rectangle(round(X1+(X2-X1)*(1/7)),round(y1+(y2-y1)*(1/7)),round(X1+(X2-X1)*(6/7)),
     round(y1+(y2-y1)*(6/7)));
 delay(100);
 effassse;
  {construction du cadre en relief}
 bar(X1+1,Y1+1,X2-1,Y2-1);
 setcolor(lightblue);
 {setlinestyle(solidln,1,normwidth);}
 setlinestyle(solidln,1,ThickWidth);
 rectangle(x1,Y1,X2,Y2);
 setlinestyle(solidln,1,normwidth);
 setcolor(white);
 rectangle(x1-2,y1-2,x2+2,Y2+2);
 setfillstyle(1,black);
 bar(X2+3,Y1+5,X2+7,Y2+2);

 setfillstyle(1,black);
 bar(X1+5,Y2+3,X2+7,Y2+7);
 {fixation de numero,films,mode de paiement}

end;   {fenetre_locale}

 PROCEDURE fenetre(couleur:word);
begin
 {cleardevice;
 setfillstyle(1,lightblue);
 bar(0,0,640,480);}

 i:=0;
 repeat    {on va essayer de donner l'idee d'une fenetre grossissante}
 begin
  setfillstyle(1,black);        {d'abord on trace les contours en noir}
  bar(284-i,282-i,366+i ,287+i);
  bar(362-i,204-i,367+i,287+i);
  setfillstyle(1,white);        {puis ce en blanc}
  bar(275-i,198-i,356+i,194+i);
  bar(275-i,198-i,279+i,276+i);
  setfillstyle(1,couleur);         {puis le cadre centrale en vert}
  {320,240}
  bar(280-i,200-i,360+i,280+i);
  setcolor(yellow);              {puis le tour}
  rectangle(279-i,199-i,361+i,281+i);
 end;
 i:=i+15; delay(20);
 until i>175;  {coordonne de la fenetre: 104,24,536,456}
end;

 FUNCTION enlettre(chif:real):string;
var
mot:string[20];
begin
 str(chif:2:2,mot);
 enlettre:=mot;
end;

PROCEDURE first;
var
i,j:integer;
begin
 randomize;
 if nonx then begin  {si on est a l'ancienne version}
               couleur1:=lightblue;
               couleur2:=blue;
              end;
 {couleur1:=DarkGray;
 couleur2:=lightgray;}
 for j:=0 to 160 do
 for i:=0 to 160 do begin
                       if odd(i+random(2)) then jpix(i,j,couleur1)
                       else jpix(i,j,couleur2);
                      end;
 size:=imagesize(0,0,160,160);
 getmem(c,size);
 getimage(0,0,160,160,c^);
 ouix:=false;
end;

PROCEDURE pinceau;
var
i,j:integer;
begin
 if ouix=true then first;
 i:=0;
 j:=0;
 repeat
  putimage(i,j,c^,normalput);
  inc(i,160);
           if i+160>=640 then dec(i); {autrement, il reste un bout non couvert sur le cote}
           if i>640 then begin
                           i:=0;
                           inc(j,160);
                          end;
 until j>480;
end;

PROCEDURE initpinceau;
begin
 ouix:=true;
 nonx:=true;
end;

PROCEDURE initpinceau2(c1,c2:word);
begin
 ouix:=true;
 nonx:=false;
 couleur1:=c1;
 couleur2:=c2;
end;

PROCEDURE donepinceau;
begin
 freemem(c,160*160);
end;


PROCEDURE scanimage(mot:string;corx1,corx2,cory1,cory2:word);
var
i,j,k,c1,c2,c3,i2,j2,n,v:word;
vrai:boolean;


			 PROCEDURE triangle;
			 var n,v,i3,j3:word;
				 ouin:boolean;
				 bouh:boolean;
			   Begin
				i2:=i;
				j2:=j;
				ouin:=false;
				  bouh:=false;
				 repeat
				  if not(bouh) then
				  begin
				   inc(i2);
				   for n:=j to j2 do if (getpixel(i2,n)<>c1) or
                                                  (i2>corx2) then
                                                                begin
																 bouh:=true;
																 dec(i2);
																end;
				  end;
				  if not(ouin) then
				  begin
				   inc(j2);
				   for n:=i to i2 do if (getpixel(n,j2)<>c1) or
                                                  (j2>cory2) then
                                                               begin
																 ouin:=true;
																 dec(j2);
																end;
				  end;
				 until (ouin) and (bouh);
				 bar(i,j,i2,j2);
			   End;


Begin
 assign(fichier,mot);
 rewrite(fichier);
 setfillstyle(1,black);
 for j:=cory1 to cory2 do
 for i:=corx1 to corx2 do
  begin
     c1:=getpixel(i,j);
	 if c1<>0 then begin
					triangle;
					math[1]:=i; math[2]:=j;
					math[3]:=i2; math[4]:=j2;
					math[5]:=c1;
			    	write(fichier,math);
                   end;
  end;
 close(fichier);
End;

PROCEDURE affimage(mot:string);
var
i:longint;
begin
 assign(fichier,mot);
 {$i-}
 reset(fichier);
 {$i+}
 if ioresult<>0 then begin
					  writeln('3.141592653589793238462643383279502884197169399375105');
					  exit;
					 end;
 for i:=0  to filesize(fichier)-1 do begin
									  read(fichier,math);
									  setfillstyle(1,math[5]);
									  bar(math[1],math[2],math[3],math[4]);
                                     end;


 close(fichier);
end;


end.