{ KOMPRESE.PAS Copyright (c) Petr Koupy } { } { Komprese textu, verze 1.0. } { } { Komprese dat pomocí Huffmanova kódování a Run-Length Encoding. } { Program nemá žádné uživatelské prostředí - ovládá se výhradně } { pomocí parametrů při volání z příkazového řádku. } { Algoritmus je vhodný zejména pro kompresy textu a bitmap. } { Celá implementace ovšem spoléhá na 8 bitové dělení dat, } { takže komprese nebude efektivní na text kódováný ve formátu } { Unicode a na více než 8 bitové bitmapy. } { Program vznikl jako zápočtový program předmětu Programování I. } { K programu je přiložen komentovaný zdrojový kód a malá sada } { testovacích dat. } { Zaujímavé je grafické spracovanie pomocou systémovej jednotky crt.} { } { Datum:12.02.2008 http://www.trsek.com } program Komprese; const povinne=4; {pocet povinnych parametru} celkem=6; {celkovy mozny pocet parametru} type bitove_pole = array[0..15] of boolean; {reprezentace byte nebo word po jednotlivych bitech} var vstupni_soubor: file; vystupni_soubor: file; log_soubor: text; vypis: boolean; {logovani zapnuto/vypnuto} {Interface >>>} function KompresniPomer: string; var ratio: real; temp: string; begin if FileSize(vstupni_soubor)>0 then ratio:=(FileSize(vystupni_soubor))/(FileSize(vstupni_soubor)) else ratio:=0; Str(ratio:4:2,temp); {temp je kvuli kompilatoru Borland Pascal} KompresniPomer:=temp; {pro kompilator Freepascal by stacilo dat KompresniPomer do predchozi procedury} end; procedure Zaznamenej(hlaseni: string); begin if vypis=true then writeln(log_soubor,hlaseni); end; function NactiByte(var data: byte): boolean; begin if not eof(vstupni_soubor) then begin BlockRead(vstupni_soubor,data,1); NactiByte:=true; end else NactiByte:=false; end; procedure UlozByte(data: byte); begin BlockWrite(vystupni_soubor,data,1); end; function NactiWord(var data: word): boolean; begin if not eof(vstupni_soubor) then begin BlockRead(vstupni_soubor,data,2); NactiWord:=true; end else NactiWord:=false; end; procedure UlozWord(data: word); begin BlockWrite(vystupni_soubor,data,2); end; procedure UkazNa(ukazatel: longint); begin Seek(vstupni_soubor,ukazatel); end; function PoziceSouboru: longint; begin PoziceSouboru:=FilePos(vstupni_soubor); end; function VelikostSouboru: longint; begin VelikostSouboru:=FileSize(vstupni_soubor); end; procedure RozlozByte(var vystup: bitove_pole; vstup: byte); var i: byte; begin for i:=0 to 7 do begin vystup[i]:=(vstup mod 2 = 1); vstup:=vstup div 2; end; end; procedure SlozByte(vstup: bitove_pole; var vystup: byte); var i, rad: byte; begin rad:=1; vystup:=0; for i:=0 to 7 do begin vystup:=vystup+rad*Ord(vstup[i]); rad:=2*rad; end; end; procedure RozlozWord(var vystup: bitove_pole; vstup: word); var i: byte; begin for i:=0 to 15 do begin vystup[i]:=(vstup mod 2 = 1); vstup:=vstup div 2; end; end; procedure SlozWord(vstup: bitove_pole; var vystup: word); var i: byte; rad: word; begin rad:=1; vystup:=0; for i:=0 to 15 do begin vystup:=vystup+rad*Ord(vstup[i]); rad:=2*rad; end; end; {<<< Interface} {ENGINE >>>} procedure HuffmanEncode; var frekvence: array[0..510] of longint; {Krome frekvenci bytu obsahuje i hodnoty otcu v Huffmanove strome, ktere jsou tvoreny soucty svych synu. Hodnoty 0..255 jsou rezervovany pro frekvence bytu. Hodnoty 256..510 jsou rezervovany pro otcovske soucty. Cim vice se zprava blizi indexu 256, tim vetsi soucet lze ocekavat - tim blize je totiz otec u korene stromu.} halda: array[1..256] of word; velikost_haldy: word; {1..256 - nula by delala problemy pri praci s haldou v poli} {Halda bude obsahovat maximalne vsechny byty. Pri tvorbe Huffmanova stromu bude znicena. Budou do ni take prubezne ukladany hodnoty otcu, takze nestaci rozsah jednoho bytu (proto pouzit word).} struktura: array[0..510] of longint; {Pro kazdy uzel stromu obsahuje index do pole 'frekvence' na sveho otce. Pokud je index otce zaporny, je dany byte jeho pravym synem, jinak je levym synem.} kod: array[0..255] of word; delka: array[0..255] of byte; {Kazdy byte je reprezentovan pravymi delka[byte] cisly z binarniho cisla kod[byte].} procedure SpocitejFrekvence; {Vypocita frekvencni vyskyt vsech bytu a ulozi je do pole.} var data: byte; i: word; index, freq: string; {pomocne retezce pro logovani} begin UkazNa(0); for i:=0 to 510 do frekvence[i]:=0; {nulovani pole} while NactiByte(data) do if frekvence[data]0 then begin Str(i,index); Str(frekvence[i],freq); Zaznamenej('Byte '+index+' ma frekvenci '+freq); end; end; end; procedure BublejDolu(uzel: word); {Danym bytem probubla vznikajici haldu dolu. Porovnavani je neprime podle frekvence. Dolu probublavaji prvky s velkou frekvenci.} var syn, pom: word; begin while uzel<=(velikost_haldy div 2) do begin syn:=2*uzel; if (synfrekvence[halda[syn+1]]) then inc(syn); if frekvence[halda[uzel]]<=frekvence[halda[syn]] then break; pom:=halda[uzel]; halda[uzel]:=halda[syn]; halda[syn]:=pom; uzel:=syn; end; end; procedure VytvorHaldu; {Z bytu o nenulove frekvenci vytvori sestupnou haldu.} var i: word; index, heap, freq: string; {pomocne retezce pro logovani} begin velikost_haldy:=0; for i:=0 to 255 do {hledani bytu s nenulovou frekvenci} if frekvence[i]>0 then begin inc(velikost_haldy); halda[velikost_haldy]:=i; end; for i:=velikost_haldy downto 1 do BublejDolu(i); {tvorba haldy} for i:=1 to velikost_haldy do {logovani} begin Str(i,index); Str(halda[i],heap); Str(frekvence[halda[i]],freq); Zaznamenej('Halda['+index+'] obsahuje byte '+heap+' s frekvenci '+freq); end; end; procedure HuffmanTree; {Vytvori Huffmanuv strom, kde listy jsou byty a jednotlive uzly jsou soucty svych synu. Postupne se likviduje halda odebiranim dvou nejmensich prvku a pridanim jejich souctu. Nakonec v halde zbyde pouze soucet pres vsechny jeji prvky. Pri tomto procesu se vytvori Huffmanuv strom, ktery je reprezentovan dvema poli. Pole 'frekvence' obsahuje data stromu. Pole 'struktura' obsahuje informace o navaznosti jednotlivych uzlu na sve otce.} var pom: word; i: word; index, freq, dad: string; {pomocne retezce pro logovani} begin for i:=0 to 510 do struktura[i]:=0; if velikost_haldy=1 then struktura[halda[1]]:=256; {v pripade, ze cely vstupni soubor je slozen ze stejnych bytu} while velikost_haldy>1 do begin pom:=halda[1]; halda[1]:=halda[velikost_haldy]; {odebrani nejmensiho prvku z haldy} dec(velikost_haldy); BublejDolu(1); {nalezeni noveho nejmensiho prvku} frekvence[255+velikost_haldy]:=frekvence[pom]+frekvence[halda[1]]; {tvorba otce dvou nejmensich prvku} struktura[pom]:=255+velikost_haldy; {index otce prvniho nejmensiho prvku bude kladny - je levym synem} struktura[halda[1]]:=-255-velikost_haldy; {index otce druheho nejmensiho prvku bude zaporny - je pravym synem} halda[1]:=255+velikost_haldy; {ulozeni otce do haldy} BublejDolu(1); end; struktura[255+velikost_haldy]:=0; {koren jiz nema otce} for i:=0 to 510 do {logovani} begin if frekvence[i]>0 then begin Str(i,index); Str(frekvence[i],freq); Str(struktura[i],dad); Zaznamenej('Frekvence['+index+'] = '+freq+' (otec = '+dad+')'); end; end; end; procedure HuffmanCode; {Vytvori kodovaci pole pro snadnejsi kodovani vstupniho souboru a ulozeni nezbytnych informaci pro rekonstrukci Huffmanova stromu. Pro kazdy byte se projde zespodu stromem a zaznamena se jeho cesta ve forme binarniho cisla, kde jeho delka je delkou cesty, hodnota 0 znamena levy syn, hodnota 1 znamena pravy syn. Binarni cislo je prevedeno na word a ulozeno do pole 'kod'. Jeho delka je ulozena do pole 'delka'. Nasledne jsou tyto pole prokladane ulozena do vystupniho souboru.} var i, delka_data: byte; kod_data, smerovnik: word; uzel: longint; index, code, lng: string; {pomocne retezce pro logovani} begin for i:=0 to 255 do begin if frekvence[i]=0 then {nulove frekvence maji nulovy kod i delku} begin kod[i]:=0; delka[i]:=0; end else begin delka_data:=0; kod_data:=0; smerovnik:=1; {postupne bude obsahovat 1,2,4,8... tedy binarne 1,10,100,1000...} uzel:=struktura[i]; {otec bytu i} while uzel<>0 do {dokud se nedojde ke koreni} begin if uzel<0 then {uzel je pravym synem, je nutne zakodovat 1} begin kod_data:=kod_data+smerovnik; {pravy smer je kodovan 1} uzel:=-uzel; end; uzel:=struktura[uzel]; {prechod na vyssi uroven stromu} smerovnik:=2*smerovnik; {v binarni reprezentaci se 1 posune doleva o jednu pozici} inc(delka_data); end; kod[i]:=kod_data; {konecne prirazeni hodnot} delka[i]:=delka_data; end; end; for i:=0 to 255 do {logovani} if frekvence[i]>0 then begin Str(i,index); Str(kod[i],code); Str(delka[i],lng); Zaznamenej('Kod['+index+'] = '+code+' (delka = '+lng+')'); end; for i:=0 to 255 do {ukladani dat do vystupniho souboru} begin UlozWord(kod[i]); UlozByte(delka[i]); end; end; procedure Encode; {Kazdy byte vstupniho souboru je preveden na svuj kod. Ten je nasledne rozlozen na jednotlive bity dle pole 'delka'. Temito bity je postupne plnen vystupni byte, ktery je po svem naplneni ulozen do vystupniho souboru. Specialni pozornost je venovana poslednimu bytu, ktery nemusi byt uplny. Informace o jeho neuplnosti je ulozena do posledniho bytu celeho souboru.} var i, vstup, vystup, pozice: byte; vstupni_word, vystupni_byte: bitove_pole; begin pozice:=7; {ukazatel do vystupniho bytu, nejvyssi rad ma ukazatel 7, nejnizsi 0} UkazNa(0); {vstupni soubor cist od zacatku} while NactiByte(vstup) do begin RozlozWord(vstupni_word,kod[vstup]); for i:=(delka[vstup]-1) downto 0 do begin vystupni_byte[pozice]:=vstupni_word[i]; if pozice=0 then {vystupni byte byl naplnen, je treba jej ulozit} begin SlozByte(vystupni_byte,vystup); UlozByte(vystup); pozice:=7; {reset} end else dec(pozice); end; end; if pozice<7 then {zbyl neuplny byte? - hodnota 7 kvuli reset (viz vyse)} begin for i:=pozice downto 0 do vystupni_byte[pozice]:=false; {doplneni nulami} SlozByte(vystupni_byte,vystup); {ulozeni zbyleho bytu} UlozByte(vystup); end; if pozice<7 then UlozByte(pozice+1) else UlozByte(0); {na konec vystupniho souboru se ulozi pocet bitu, ktere je treba pri dekompresi ignorovat} end; begin Zaznamenej('Zahajena komprese (Huffman).'); SpocitejFrekvence; VytvorHaldu; HuffmanTree; HuffmanCode; Encode; Zaznamenej('Ukoncena komprese (Huffman).'); Zaznamenej('Kompresni pomer = '+KompresniPomer); end; procedure HuffmanDecode; type pprvek=^prvek; prvek=record {uzel stromu} list: boolean; {je uzel listem nebo ne?} data: byte; {v listu ulozen dekodovaci byte, jinak nahodna hodnota} pravy: pprvek; {v listu bude nil} levy: pprvek; {v listu bude nil} end; var kod: array[0..255] of word; delka: array[0..255] of byte; koren: pprvek; chyba: boolean; {kontrola spravnosti vstupniho souboru} procedure NactiPole; {Obnovi pole 'kod' a 'delka', ktere obsahuji nezbytne informace pro rekonstrukci stromu.} var i: byte; index, code, lng: string; {pomocne retezce pro logovani} begin for i:=0 to 255 do {nacitani dat ze vstupniho souboru} begin if NactiWord(kod[i])=false then chyba:=true; if NactiByte(delka[i])=false then chyba:=true; {chyba, pokud vstupni soubor neobsahuje ani nezbytne informace pro rekonstrukci stromu} end; for i:=0 to 255 do {logovani} if (delka[i]>0) and (chyba=false) then begin Str(i,index); Str(kod[i],code); Str(delka[i],lng); Zaznamenej('Kod['+index+'] = '+code+' (delka = '+lng+')'); end; end; procedure VytvorStrom(var koren: pprvek); {Za pomoci informaci z poli 'kod' a 'delka' je rekonstruovan Huffmanuv strom. Je reprezentovan ukazately na zaznamy, ve kterych je ukazatel na praveho a leveho syna, identifikator listu a dale hodnota uzlu. Hodnota listu reprezentuje cilovy dekodovany byte.} var i, j: byte; vstupni_word: bitove_pole; uzel, novy: pprvek; begin new(koren); {inicializace korene} uzel:=koren; uzel^.pravy:=nil; uzel^.levy:=nil; uzel^.list:=false; for i:=0 to 255 do begin uzel:=koren; RozlozWord(vstupni_word,kod[i]); for j:=(delka[i]-1) downto 0 do {prochazeni 'neproslapanou' cestou} begin if vstupni_word[j]=true then {jdu doprava} begin if uzel^.pravy=nil then {pokud cesta neexistuje, tak vytvorit} begin new(novy); uzel^.pravy:=novy; uzel:=novy; uzel^.pravy:=nil; uzel^.levy:=nil; uzel^.list:=false; end else uzel:=uzel^.pravy; {cesta jiz existuje, pouze projit dale} end else {jdu doleva} begin if uzel^.levy=nil then {pokud cesta neexistuje, tak vytvorit} begin new(novy); uzel^.levy:=novy; uzel:=novy; uzel^.pravy:=nil; uzel^.levy:=nil; uzel^.list:=false; end else uzel:=uzel^.levy; {cesta jiz existuje, pouze projit dale} end; if j=0 then {konec cesty - je nutne ulozit cilovou hodnotu} begin uzel^.data:=i; uzel^.list:=true; end; end; end; Zaznamenej('Rekonstrukce Huffmanova stromu dokoncena.'); end; procedure Decode; {Vstupni byty budou nacitany jako kontinualni cesta Huffmanovym stromem. Pokazde kdyz se dojde do listu je ulozen vystupni byte a ukazatel je vracen na koren stromu. Procedura take hlida posledni potencialne neuplny byte, ve kterem je mozna potreba ignorovat nekolik bitu.} var vstup, i, ignorovat: byte; velikost, pozice: longint; vstupni_byte: bitove_pole; uzel: pprvek; begin uzel:=koren; velikost:=VelikostSouboru; pozice:=PoziceSouboru; UkazNa(velikost-1); {presun na konec} NactiByte(ignorovat); {kolik je potreba na konci ignorovat?} UkazNa(pozice); {zpatky na puvodni misto} while (PoziceSouboru<(velikost-1)) and (NactiByte(vstup)) and (chyba=false) do {POZOR - NactiByte posunuje pozici, proto je v podmince PoziceSouboru napred} {posledni byte = EOF, predposledni byte = pocet ignorovanych bitu, oba byty se nesmi dekodovat} begin RozlozByte(vstupni_byte,vstup); pozice:=PoziceSouboru-1; {protoze NactiByte posune pozici na budouci byte, je nutne dekrementovat} for i:=7 downto 0 do begin if (pozice=(velikost-2)) and (ignorovat>i) then {v poslednim bytu jsou ignorovane bity} begin {nedelat nic, bity jsou ignorovany} end else begin if chyba=false then if vstupni_byte[i]=false then {sestoupit ve strome doleva} if uzel^.levy<>nil then uzel:=uzel^.levy else chyba:=true else {sestoupit ve strome doprava} if uzel^.pravy<>nil then uzel:=uzel^.pravy else chyba:=true; {pokud je algoritmus navigovan neexistujici cestou, urcite data neodpovidaji stromu - tzn. bud je soubor poskozen anebo se uzivatel pokousi dekomprimovat cizi soubor} if (uzel^.list=true) and (chyba=false) then {nalezen list} begin UlozByte(uzel^.data); uzel:=koren; {reset} end; end; end; end; end; begin Zaznamenej('Zahajena dekomprese (Huffman).'); chyba:=false; NactiPole; if chyba=false then VytvorStrom(koren); if chyba=false then Decode; if chyba=false then Zaznamenej('Ukoncena dekomprese (Huffman).') else Zaznamenej('Vstupni soubor je poskozen nebo se nejedna o soubor vytvoreny timto programem.'); end; procedure RLEEncode; var frekvence: array[0..255] of longint; escape: byte; {escape character pro identifikaci zkomprimovane sekvence bytu} procedure SpocitejFrekvence; {Vypocita frekvencni vyskyt vsech bytu a ulozi je do pole.} var data: byte; i: word; index, freq: string; {pomocne retezce pro logovani} begin UkazNa(0); for i:=0 to 255 do frekvence[i]:=0; {nulovani pole} while NactiByte(data) do if frekvence[data]0 then begin Str(i,index); Str(frekvence[i],freq); Zaznamenej('Byte '+index+' ma frekvenci '+freq); end; end; end; procedure NajdiEscape; {Prvni znak s nejnizsi frekvenci bude escape characterem.} var i: byte; min: longint; esc: string; begin min:=frekvence[0]; escape:=0; for i:=1 to 255 do begin if frekvence[i]>>} procedure Komprimuj; begin if paramstr(4)='-h' then HuffmanEncode; if paramstr(4)='-r' then RLEEncode; end; procedure Dekomprimuj; begin if paramstr(4)='-h' then HuffmanDecode; if paramstr(4)='-r' then RLEDecode; end; {<<< Rizeni cinnosti} {I/O procedury >>>} procedure ZavriVstupni; begin close(vstupni_soubor); Zaznamenej('Vstupni soubor uzavren.'); end; procedure ZavriVystupni; begin close(vystupni_soubor); Zaznamenej('Vystupni soubor uzavren.'); end; procedure ZavriLog; begin if vypis=true then close(log_soubor); end; function OtevriVstupni(jmeno: string): boolean; begin assign(vstupni_soubor,jmeno); {$I-} reset(vstupni_soubor,1); {$I+} {pokus o otevreni} if IOresult=0 then begin OtevriVstupni:=true; {soubor existuje} Zaznamenej('Vstupni soubor '+jmeno+' otevren pro cteni.'); end else begin OtevriVstupni:=false; {soubor neexistuje} Zaznamenej('Vstupni soubor '+jmeno+' neexistuje.'); end; end; function OtevriVystupni(jmeno: string): boolean; var i: byte; prepis: boolean; begin prepis:=true; assign(vystupni_soubor,jmeno); {$I-} reset(vystupni_soubor,1); {$I+} {pokus o otevreni} if IOresult=0 then {soubor uz existuje} begin close(vystupni_soubor); prepis:=false; for i:=(povinne+1) to paramcount do {lze jej prepsat?} if paramstr(i)='-w' then prepis:=true; end; if prepis=true then begin rewrite(vystupni_soubor,1); OtevriVystupni:=true; {soubor lze zapisovat} Zaznamenej('Vystupni soubor '+jmeno+' otevren pro zapis.'); end else begin OtevriVystupni:=false; {soubor nelze zapisovat} Zaznamenej('Vystupni soubor '+jmeno+' nelze zapisovat.'); ZavriVstupni; {kvuli zkracenemu vyhodnoceni v hlavnim programu} end; end; procedure OtevriLog; var i: byte; begin vypis:=false; for i:=(povinne+1) to paramcount do {jsou zapnute vypisy?} if paramstr(i)='-l' then vypis:=true; if vypis=true then begin assign(log_soubor,'log.txt'); rewrite(log_soubor); end; end; {<<< I/O procedury} begin if (paramcount>=povinne) and (paramcount<=celkem) then begin OtevriLog; if OtevriVstupni(paramstr(1)) and OtevriVystupni(paramstr(2)) then begin if paramstr(3)='-c' then Komprimuj; if paramstr(3)='-d' then Dekomprimuj; ZavriVstupni; ZavriVystupni; end; ZavriLog; end else begin {help} writeln; writeln('Komprese textu, verze 1.0'); writeln('Copyright (c) 2008 Petr Koupy'); writeln; writeln('komprese.exe VSTUP VYSTUP [rezim] [algoritmus] ([prepis] [logovani])'); writeln; writeln('Nazvy souboru uvadet bez cesty.'); writeln('[rezim] -c komprese vstupniho souboru'); writeln(' -d dekomprese vstupniho souboru'); writeln('[algoritmus] -h Huffmanovo kodovani'); writeln(' -r Run-Lenght Encoding'); writeln('[prepis] -w povolit prepis existujiciho vystupniho souboru (nepovinne)'); writeln('[logovani] -l povolit logovani udalosti do souboru log.txt (nepovinne)'); end; end.