home *** CD-ROM | disk | FTP | other *** search
/ Intermedia 1998 January / inter1_98.iso / www / rozi / GIF.ZIP / SHOWGIF.PAS < prev    next >
Pascal/Delphi Source File  |  1997-01-12  |  9KB  |  353 lines
  1. { ======== Program u╛ywa niestandardowego sterownika VESA.BGI ========== }
  2. {$r-,i-}
  3. unit ShowGif;
  4.  
  5. interface
  6.  
  7. var
  8.     ModeNum:byte;                                            {numer trybu graficznego}
  9.  
  10. function setSvgaMode:integer;
  11. procedure Gifka(x,y:word;name:string);
  12.  
  13. implementation
  14.  
  15.  
  16. uses dos,crt,graph;
  17.  
  18. const max=4096;
  19.  
  20.       type
  21.     RodzajMapyKolorow=(globalny,lokalny);
  22.     prologGIF = record
  23.         naglowek:array [1..6] of char;
  24.     szerokoscEkranu:word;
  25.     wysokoscekranu:word;
  26.     PoleBitowe:byte;
  27.     KolorTla:byte;
  28.     PixelAspectRatio:byte;
  29.       end;
  30.         tablicaKolorow=array[globalny..lokalny,0..255]of record
  31.                                                                                                         czerwony,zielony,niebieski:byte;
  32.                                                                                                     end;
  33.     opisObrazu=record
  34.     odkolumny:word;
  35.     odlinii:word;
  36.     szerokoscObrazu:word;
  37.     WysokoscObrazu:word;
  38.     polebitowe:byte;
  39. end;
  40.  
  41. var
  42.     prolog:prologGIF;
  43.     opisobr:opisObrazu;
  44.     mapakolorow:rodzajMapyKolorow;
  45.     bitownakolor:byte;
  46.     LiczbaKolorow:array[globalny..lokalny] of word;
  47.     jestmapa:array[globalny..lokalny] of boolean;
  48.     przeplatany,koniec:boolean;
  49.     zostalobitow:shortint;
  50.     liczbabitow,odilubitow:byte;
  51.     indeksbufora,indeksdanych,ilebajtow:word;
  52.     poziom,odpoziomu,poziomstosu:word;
  53.     poprzednikod,aktualnykod:word;
  54.     koniecdanych,nowy:word;
  55.     tymczasowy,zatrzask:word;
  56.     linie,maxX,maxY,xEkr,Yekr:word;
  57.     xp,yp:word;                                            {wspóêrz⌐dne pocz}
  58.     etykieta:byte;
  59.     st,tr:integer;
  60.     naekran:procedure(kolor:byte);
  61.     nazwaZbioru:string;
  62.     zbiorGIF:file;
  63.     Kolory:tablicakolorow;
  64.     slownik:array[0..max] of record
  65.                                                          poziom:word;
  66.                                                          dana:byte;
  67.                                                      end;
  68.     stos:array[0..1024]of byte;
  69.     bufor:array [0..32767] of byte;   {buf. odczytu z dysku}
  70.     r:registers;
  71.  
  72. { ============PREZENTACJA PUNKTOW NA EKRANIE============ }
  73. {$f+}
  74. procedure naEkran1 (kolor:byte);
  75. begin
  76.     if(xekr>maxx) then begin xEkr:=0; inc(yekr); end;
  77.     if(yekr>maxy) then yekr:=0;
  78.     if(xekr<maxx) and (yekr<maxy) then
  79.         putpixel (xEkr+xp,yEkr+yp,kolor);
  80.     inc (xekr);
  81. end;
  82.  
  83. procedure naEkran2(kolor:byte); {obraz przeplatany}
  84. const yInc:array[1..5] of byte=(8,8,4,2,1);
  85.             yLin:array[1..5] of byte=(0,4,2,1,0);
  86. begin
  87.     if(xekr>maxx)then begin
  88.         xekr:=0;
  89.         inc(yekr,yinc[linie]);
  90.         if (yekr>maxy) then begin
  91.             inc(linie);
  92.             yekr:=ylin[linie];
  93.         end;
  94.     end;
  95.     if (xekr<maxx) and (yekr<maxy) then
  96.         putpixel(Xekr+xp,yekr+yp,kolor);
  97.     inc(xekr);
  98. end;
  99.  
  100. function setSvgaMode:integer;
  101. begin
  102.     setSvgaMode:=ModeNum;  {numer trybu graficznego}
  103. end;
  104. {$f-}
  105. {=======0====POBIERANIE DANYCH ZE ZBIORU GIF=====================}
  106. function wezBajt:byte;
  107. begin
  108.     if (indeksbufora>=ilebajtow) then begin
  109.         blockread(zbiorGIF,bufor,sizeof(bufor),ilebajtow);
  110.         if (ilebajtow=0) then begin wezbajt:=0;exit; end;
  111.         indeksbufora:=0;
  112.     end;
  113.     wezbajt:=bufor[indeksbufora];
  114.     inc(indeksbufora);
  115. end;
  116.  
  117. procedure wezBlok(var v;ile:word);
  118. var W:word;
  119. begin
  120.     if ile>ilebajtow then w:=ilebajtow else w:=ile;
  121.     move (bufor[indeksbufora],v,w);
  122.     dec (ile,w);
  123.     inc(indeksbufora,w);
  124.     if (indeksbufora>=ilebajtow) then begin
  125.         blockread (zbiorgif,bufor,sizeof(bufor),ilebajtow);
  126.         if (ilebajtow=0) then exit;
  127.         indeksbufora:=0;
  128.     end;
  129.     move(bufor[indeksbufora],v,ile);
  130.     inc(indeksbufora,ile);
  131. end;
  132.  
  133. function wezBajtDanych:word;
  134. begin
  135.     if (indeksdanych=0) then indeksdanych:=wezbajt;
  136.     if (indeksdanych>=1) then begin
  137.         wezbajtdanych:=wezbajt;
  138.         dec(indeksdanych);
  139.     end
  140.     else wezbajtdanych:=max+1;
  141. end;
  142.  
  143. function wezKod (ilebitow:byte):word;
  144. const maska:array[1..8] of byte=($01,$03,$07,$0f,$1f,$3f,$7f,$ff);
  145. var trzebabitow,ile:byte;
  146.         kod:word;
  147. begin
  148.     trzebabitow:=ilebitow;
  149.     kod:=0;
  150.     while (trzebabitow>0) do begin
  151.         if (zostalobitow<=0) then
  152.         begin
  153.             zatrzask:=wezbajtdanych;
  154.             if zatrzask>max then begin  wezkod:=koniecdanych;exit;end;
  155.             zostalobitow:=8;
  156.         end;
  157.         if (trzebabitow>=zostalobitow) then ile:=zostalobitow
  158.         else ile:=trzebabitow;
  159.         kod:=kod or ((zatrzask and maska[ile]) shl (ilebitow-trzebabitow));
  160.         zatrzask:=zatrzask shr ile;
  161.         dec(trzebabitow,ile);
  162.         dec(zostalobitow,ile);
  163.     end;
  164.     wezkod:=kod;
  165. end;
  166. {===================== DEKOMPRESJA OBRAZU ======================}
  167. procedure inicjuj;
  168. begin
  169.     liczbabitow:=odilubitow+1;
  170.     poziom:=1 shl odilubitow;
  171.     nowy:=poziom; koniecdanych:=poziom+1;
  172.     inc (poziom,2);
  173.     odpoziomu:=poziom;
  174. end;
  175.  
  176. procedure rozpakuj;
  177. var c:char;
  178. begin
  179.     indeksdanych:=0;
  180.     poziomstosu:=0;
  181.     zostalobitow:=0;
  182.     odilubitow:=wezbajt;
  183.     if odilubitow=0 then exit;
  184.     fillchar(slownik,sizeof(slownik),0);
  185.     inicjuj;
  186.     aktualnykod:=wezkod(liczbabitow);
  187.     while (aktualnykod<>koniecdanych) do begin
  188.         if (aktualnykod=nowy) then    begin
  189.             inicjuj;
  190.             aktualnykod:=wezkod(liczbabitow);
  191.             slownik[poziom-1].dana:=aktualnykod;
  192.             poprzednikod:=aktualnykod;
  193.             naekran(aktualnykod);
  194.         end
  195.         else begin
  196.             tymczasowy:=aktualnykod;
  197.             if (aktualnykod>=poziom) then  {1}
  198.             begin
  199.                 aktualnykod:=poprzednikod;
  200.                 stos[poziomstosu]:=slownik[poziom-1].dana;
  201.                 inc (poziomstosu);
  202.             end;
  203.             while (aktualnykod>=odpoziomu) do {2}
  204.             begin
  205.                 stos[poziomstosu]:=slownik[aktualnykod].dana;
  206.                 aktualnykod:=slownik[aktualnykod].poziom;
  207.                 inc (poziomstosu);
  208.             end;
  209.             stos[poziomstosu]:=aktualnykod; {3}
  210.             inc(poziomstosu);
  211.             while (poziomstosu>0) do
  212.             begin
  213.                 dec(poziomstosu);
  214.                 naekran (stos[poziomstosu]);
  215.             end;
  216.             slownik[poziom].poziom:=poprzednikod; {4}
  217.             slownik[poziom].dana:=aktualnykod;
  218.             inc(poziom);
  219.             poprzednikod:=tymczasowy;
  220.             if (poziom shr liczbabitow>0) and (liczbabitow<12) then inc(liczbabitow); {*}
  221.         end;
  222.         if keypressed then begin koniec:=true; exit; end;
  223.         aktualnykod:=wezkod(liczbabitow);
  224.     end;
  225.     aktualnykod:=wezkod(liczbabitow);
  226.  end;
  227.  
  228. {=============== POBIERANIE POSZCZEGOLNYCH BLOKOW ==============}
  229. procedure ominrozszerzenie;
  230. var b:byte;
  231.         s:string;
  232. begin
  233.     b:=wezbajt;   {pobranie etykiety bez jej interpretacji}
  234.     b:=wezbajt;   {pobranie dlugosci bloku}
  235.     while (b>0) do
  236.     begin
  237.         wezblok(s,b);
  238.         b:=wezbajt;
  239.     end;
  240. end;
  241.  
  242. procedure wezprolog;
  243. var b:byte;
  244. begin
  245.     wezblok(prolog,sizeof(prolog));
  246.     b:=prolog.polebitowe;
  247.     jestmapa[globalny]:=(b and $80>0);
  248.     liczbakolorow[globalny]:=1 shl (b and $07+1);
  249.     bitownakolor:=(b and $7f) shr 4+1;
  250. end;
  251.  
  252. procedure wezopisobrazu;
  253. var b:byte;
  254. begin
  255.     wezblok(opisobr,sizeof(opisobr));
  256.     b:=opisobr.polebitowe;
  257.     jestmapa[lokalny]:=(b and $80>0);
  258.     liczbakolorow[lokalny]:=1 shl (b and $07+1);
  259.     przeplatany:=(b and $40>0);
  260.     maxx:=opisobr.szerokoscObrazu-1;
  261.     maxy:=opisobr.wysokoscObrazu-1;
  262. end;
  263.  
  264. procedure wezkolory;
  265. var f,ile:word;
  266.         plik:text;
  267. begin
  268.     ile:=liczbakolorow[mapakolorow];
  269.     ile:=ile*3;
  270.     wezblok(kolory[mapakolorow],ile);
  271. end;
  272.  
  273. procedure definiujKolory;
  274. var w:word;
  275.         reg:registers;
  276. begin
  277.     for w:=0 to liczbakolorow[mapakolorow]-1 do
  278.         with kolory[mapakolorow][w] do
  279.         begin
  280.             czerwony:=czerwony shr 2;
  281.             zielony:=zielony shr 2;
  282.             niebieski:=niebieski shr 2;
  283.         end;
  284.         reg.ax:=$1012;
  285.         reg.bx:=0;
  286.         reg.cx:=liczbakolorow[mapakolorow];
  287.         reg.es:=seg(kolory);
  288.         reg.dx:=ofs(kolory[mapakolorow]);
  289.         intr($10,reg);
  290. end;
  291.  
  292. procedure Gifka;
  293. begin
  294.     nazwazbioru:=name;
  295.     xp:=x;yp:=y;
  296.     xekr:=x;yekr:=y;
  297.     assign(zbiorgif,nazwazbioru);
  298.     reset (zbiorgif,1);
  299.     if (ioresult<>0) then exit;
  300.     ilebajtow:=0;
  301.     indeksbufora:=0;
  302.     wezprolog;
  303. {    if prolog.szerokoscekranu>prolog.wysokoscekranu then
  304.     begin
  305.         if prolog.szerokoscekranu<320 then modeNum:=0;
  306.         if (prolog.szerokoscekranu>320) and (prolog.szerokoscekranu<=640) then modeNum:=2;
  307.         if (prolog.szerokoscekranu>640) and (prolog.szerokoscekranu<=800) then modeNum:=3;
  308.         if (prolog.szerokoscekranu>800) then modeNum:=4;
  309.     end;
  310.     if prolog.szerokoscekranu<prolog.wysokoscekranu then begin
  311.         if prolog.wysokoscekranu<200 then modeNum:=0;
  312.         if (prolog.wysokoscekranu>200) and (prolog.wysokoscekranu<480) then modeNum:=2;
  313.         if (prolog.wysokoscekranu>480) and (prolog.wysokoscekranu <600) then modeNum:=3;
  314.         if (prolog.wysokoscekranu>600) then modeNum:=4;
  315.     end;}
  316.     with prolog do
  317.         if (naglowek<>'GIF87a') and (naglowek<>'GIF89a') then begin
  318.             close(zbiorgif);
  319.             writeln ('Zbior nie jest zgodny z formatem GIF !');
  320.             exit;
  321.         end;
  322.     mapakolorow:=globalny;
  323.     if jestmapa[globalny] then wezkolory;
  324. {    st:=installUserDriver('VESA',@setsvgamode);
  325.     st:=detect;
  326.     initgraph(st,tr,'');}
  327.     koniec:=false;
  328.     repeat
  329.         etykieta:=wezbajt;
  330.         case etykieta of
  331.             $2c:begin
  332.                 wezopisObrazu;
  333.                 if przeplatany then begin linie:=1; naekran:=naekran2; end
  334.                 else naekran:=naekran1;
  335.                 if jestmapa[lokalny] then
  336.                 begin
  337.                     mapakolorow:=lokalny;
  338.                     wezkolory;
  339.                 end;
  340.                 definiujkolory;
  341.                 xEkr:=0; yEkr:=0;
  342.                 rozpakuj;
  343.                 mapakolorow:=globalny;
  344.             end;
  345.             $21:ominrozszerzenie;
  346.             0,$3b:koniec:=true;
  347.         end;
  348.     until koniec;
  349.     setcolor (white);
  350.     close(zbiorGIF);
  351. end;
  352.  
  353. end.