home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 17 / CD_ASCQ_17_101194.iso / dos / prg / vidal / pascal / compact.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-07-21  |  5.0 KB  |  212 lines
  1. {programme de compactage d'image , algorythme du quad tree }
  2. { ou arbre a quatre branche}
  3. { on regarde si le rectangle est forme de la meme couleur }
  4. { si oui alors on sauvegarde en memoire , les specifications
  5.  du rectangle , ou alors la forme de arbre }
  6. { si non on divise le carre en 4 , et on aplique recursivement pour les
  7.  4 petits carres le meme algorythme }
  8. { l'Autre algorythme est sur le meme principe
  9.  on ne coupe pas en quatre carre , mais en trois rectangles
  10.   dont l'un est homogene en couleur
  11.    (donc recherche du rectangle le plus grand de la meme couleur)
  12.   ,et on applique la meme chose pour les deux autres rectangles}
  13.  
  14. program compactage;
  15. uses crt,graph;
  16. const max=5000;
  17. type ca= RECORD
  18.           c: word;
  19.           l: word;
  20.           h: word;
  21.           x: word;
  22.           y: word;
  23.          END;
  24.      tab= array[1..max] of ca;
  25. var t: tab;
  26.     i,ni: word;
  27.     a: char;
  28.  
  29. PROCEDURE INITGRAPHIC ;
  30. VAR
  31.     GraphDriver , GraphMode ,CodeErreur : integer ;
  32. BEGIN
  33.     GraphDriver := Detect ;
  34.     InitGraph (GraphDriver,GraphMode,'c:\t7\bgi') ;
  35.     CodeErreur  := GraphResult ;
  36.     If CodeErreur <> GrOk Then
  37.       Begin
  38.          Writeln ('Erreur en mode graphique : ',GraphErrorMsg (GraphDriver));
  39.          Readln ;
  40.          Halt (1) ;
  41.        End ;
  42. END ;
  43. {regarde si un rectangle est rempli d'une couleur unique}
  44. function homogene(x,y,lar,hau:word):boolean;
  45. var xt,yt,c,cn:word;
  46.        test: boolean;
  47. BEGIN
  48.   xt:=0;
  49.   test:=true;
  50.   c:=getpixel(x,y);
  51.   repeat
  52.     yt:=0;
  53.      repeat
  54.       cn:=getpixel(x+xt,y+yt);
  55.       if c<>cn then test:=false;
  56.       c:=cn;
  57.       inc (yt);
  58.      until (yt>=lar) or (not(test));
  59.     inc(xt);
  60.   until (xt>=hau) or (not(test));
  61.   homogene:=test;
  62. END;
  63.  
  64. {compactage quad tree }
  65. procedure  COMPACTE(x,y,lar:word);
  66. var test: boolean;
  67.     c: word;
  68. BEGIN
  69.  test:=homogene(x,y,lar,lar);
  70.  if test then
  71.              BEGIN
  72.                t[i].l:=lar;
  73.                t[i].h:=lar;
  74.                t[i].x:=x;
  75.                t[i].y:=y;
  76.                t[i].c:=getpixel(x,y);
  77.                inc(i);
  78.                rectangle(x+270,y+10,x+lar+270,y+lar+10);
  79.              END
  80.    else  BEGIN
  81.            compacte(x,y,lar div 2);
  82.            compacte(x+lar div 2,y,lar div 2);
  83.            compacte(x+lar div 2,y+lar div 2,lar div 2);
  84.            compacte(x,y+lar div 2,lar div 2);
  85.           END;
  86. END;
  87.  
  88. procedure carre(x,y:word;lar,haut:word;c:word);
  89. var xt,yt:word;
  90. BEGIN
  91.   xt:=0;
  92.   repeat
  93.     yt:=0;
  94.      repeat
  95.       putpixel(x+xt+270,y+yt+144,c);
  96.       inc (yt);
  97.      until (yt>=lar);
  98.     inc(xt);
  99.   until (xt>=haut);
  100. END;
  101.  
  102. procedure aff( x,y,lar: word);
  103. BEGIN
  104.  
  105.   if t[i].l<lar then
  106.   BEGIN
  107.            aff(x,y,lar div 2);
  108.            aff(x+lar div 2,y,lar div 2);
  109.            aff(x,y+lar div 2,lar div 2);
  110.            aff(x+lar div 2,y+lar div 2,lar div 2);
  111.   END
  112.     else if t[i].l=lar then
  113.          BEGIN
  114.               CARRE(x,y,lar,lar,t[i].c);
  115.               inc(i);
  116.          END;
  117. END;
  118. function vn(i:word):string;
  119. var s:string;
  120. BEGIN
  121.  s:=chr(i div 1000+48);
  122.  s:=s+chr((i div 100) mod 10+48);
  123.  s:=s+chr(((i div 10) mod 10) mod 10+48);
  124.  s:=s+chr(i mod 10+48);
  125. vn:=s;
  126. END;
  127.  
  128. procedure bidoulle(n,m:word;direction:boolean);
  129. BEGIN
  130.   if direction then t[n].h:=t[n].h+t[m].h
  131.   else
  132.      t[n].l:=t[n].l+t[m].l;
  133.   t[m].l:=0;
  134.   t[m].h:=0;
  135.   t[m].x:=0;
  136.   t[m].y:=0;
  137. END;
  138.  
  139. { deuxieme algo de compactage }
  140. procedure compactdeux(i:word);
  141. var n,m: word;
  142.     test:boolean;
  143. BEGIN
  144.   test:=true;
  145.   for n:=1 to i do
  146.    if t[n].l<>0 then
  147.      BEGIN
  148.        REPEAT
  149.        test:=true;
  150.        for m:=1 to i do
  151.           BEGIN
  152.             if (t[m].l<>0) and (n<>m) and (t[n].c=t[m].c) then
  153.               BEGIN
  154.               if (t[n].x+t[n].h=t[m].x) and (t[n].l=t[m].l)
  155.                      and (t[n].y=t[m].y)
  156.                   then
  157.                  BEGIN
  158.                    bidoulle(n,m,true);
  159.                    test:=false;
  160.                  END;
  161.               if (t[n].y+t[n].l=t[m].y) and (t[n].h=t[m].h)
  162.                   and (t[n].x=t[m].x)
  163.               then
  164.                 BEGIN
  165.                  bidoulle(n,m,false);
  166.                  test:=false;
  167.                 END;
  168.             END;
  169.           END;
  170.       until test;
  171.      END;
  172. END;
  173.  
  174. procedure aff2(i:word);
  175. var n: word;
  176. BEGIN
  177.   for n:=1 to i do
  178.         if t[n].l<>0 then
  179.       rectangle(t[n].x,t[n].y+144,t[n].x+t[n].h,t[n].y+t[n].l+144);
  180. END;
  181.  
  182. procedure aff3(i:word;var ni:word);
  183. var n: word;
  184. BEGIN
  185.   ni:=0;
  186.   for n:=1 to i do
  187.         if t[n].l<>0 then
  188.       BEGIN
  189.          inc(ni);
  190.          carre(t[n].x,t[n].y,t[n].l,t[n].h,t[n].c);
  191.       END;
  192. END;
  193.  
  194. BEGIN
  195. for i:=1 to max do BEGIN t[i].l:=0;t[i].c:=0;END;
  196. i:=1;
  197. initgraphic;
  198. circle(64,64,50);
  199. floodfill(65,65,getcolor);
  200. setcolor(2);
  201. compacte(0,0,128);
  202. setcolor(getcolor);
  203. dec(i);
  204. compactdeux(i);
  205. aff2(i);
  206. {aff(0,0,256);}
  207. outtextxy(256,0,'nb feuille= '+vn(i));
  208. repeat until keypressed;
  209. aff3(i,ni);
  210. outtextxy(400,0,'nb feuille= '+vn(ni));
  211. a:=readkey;
  212. end.