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