Home » Source Code » » COMPRESS.PAS

COMPRESS.PAS ( File view )

From:
  • By 2010-07-21
  • View(s):9
  • Download(s):0
  • Point(s): 1
			{
$UNDEF test
}     {
Wenn "test" definiert ist: Programm, sonst Unit
}
{
$DEFINE RLE
}     {
Wenn "RLE"  definiert ist: Huffman _und_ RLE-Codierung
}
{
$UNDEF IOcheck
}  {
Wenn "IOcheck" definiert ist: $I+, sonst $I-
}

{
$IFDEF test
}
{
$A+,B-,D+,E+,F-,G-,I+,L+,N+,O-,R-,S+,V+,X-
}
{
$M 32768,0,655360
}
{
$ELSE
}
{
$A+,B-,D+,E+,F-,G-,I+,L+,N+,O-,R-,S-,V-,X-
}
{
$M 32768,0,655360
}
{
$ENDIF
}

{
$IFDEF test
}
PROGRAM compression;
{
$ELSE
}
UNIT compression;
INTERFACE
{
$ENDIF
}

{
Zweck    : Datenkompression nach Huffman (und RLE)
}
{
Autor    : Kai Rohrbacher    
}
{
Sprache  : TurboPascal 6.0   
}
{
Datum    : 25.09.1992        
}
{
Anmerkung: Die zur Verfgung gestellten "FileOfBytes" bentigen eine Menge
}
{
           Speicher, so da gengend Stackspeicher vorhanden sein mu;    
}
{
           ebenso empfiehlt es sich, mit mglichst wenigen solcher Dateien
}
{
           auszukommen, Stichwort: Mehrfachausnutzung! (Unschn, aber     
}
{
           wirksam!)
}
{
           ErrorCompress enthlt den zuletzt aufgetretenen Fehler; diese  
}
{
           Variable mu vom Anwender bercksichtigt und anschlieend auf  
}
{
           CompressErr_NoError zurckgesetzt werden!
}
USES CRT,DOS;

TYPE header=ARRAY[1..3] OF BYTE;                {
Erkennungsheader fr
}
CONST Kennung:header=(ORD('H'),ORD('U'),ORD('C')); {
komprimierte Dateien
}
{
$IFDEF RLE
}
      ESC:BYTE=$1B;
      FFh:BYTE=$FF;
      TemporaryFile='_RLE.$$$';
{
$ENDIF
}

CONST BufSize=512; {
E/A-Puffergre = 512 Bytes
}

      CompressErr_NoError=0;          {
mgliche Fehlerkonstanten
}
      CompressErr_Size0  =1;
      CompressErr_AlreadyCompressed=2;
      CompressErr_FileNotFound=3;
      CompressErr_FileNotOpen=4;
      CompressErr_DiskFull=5;
      CompressErr_Unknown=255;

      CompressError:BYTE=CompressErr_NoError;

TYPE Pbranch=^branch;
     branch=RECORD
             zeichen:BYTE;
             links,rechts:Pbranch
            END;
     code=RECORD
           bitcount:BYTE; {
max. Astlnge (und damit auch Codelnge)=255 Bit!
}
           itself:ARRAY[0..31] OF BYTE {
32 Byte=256 Bits fr den Code selber
}
          END;

     Puffer=ARRAY[0..BufSize-1] OF BYTE;
     {
Folgender Typ wird nur fr einen Typecast des E/A-Puffers gebraucht
}
     {
und gehrt eindeutig in die Rubrik "dirty tricks"...
}
     Kopf=RECORD 
           info  :Header;
           Laengeunkom,Laengekom:LONGINT;
           fillup:ARRAY[SizeOf(Header)+SizeOf(LongInt)+SizeOf(LongInt)
                        ..BufSize-1] OF BYTE
          END;

     FileOfByte=RECORD
                 datei:FILE;
                 lesen,               {
lesen oder schreiben?
}
                 komprimiert:BOOLEAN; {
komprimiert oder normales File?
}
                 lenunkom,            {
unkomprimierte Bytesanzahl
}
                 lenbitskom:LONGINT;  {
Dateilnge in Bits
}
                 filebitpos:LONGINT;  {
akt. BIT-Pos. im File
}
                 position:LONGINT;    {
aktuelle Position im File
}
                 msdosSize:LONGINT;   {
totale Lnge des Files
}
                 bitzaehl:BYTE;       {
Bitzhler fr Bits in eabyte
}
                 buf:Puffer;          {
Puffer fr E/A-Operationen
}
                 bufIndex:WORD;       {
Indexzeiger in buf
}
                 bufMax:WORD;         {
-1=max. Wert von bufIndex
}
                 stamm:branch;        {
Wurzel des Codebaums
}
                 codes:ARRAY[0..255] OF code;  {
Codes selber
}
                 {
$IFDEF RLE
}
                 RLEcount:INTEGER;
                 RLEchar :BYTE;
                 {
$ENDIF
}
                END;

{
$IFNDEF test
}
 PROCEDURE WriteBits(VAR f:FileOfByte; wert,Stellen:BYTE);
 PROCEDURE ReadBits(VAR f:FileOfByte; VAR wert:BYTE; Stellen:BYTE);
 PROCEDURE _Assign(VAR f:FileOfByte; s:STRING);
 PROCEDURE _Reset(VAR f:FileOfByte);
 PROCEDURE _Rewrite(VAR f:FileOfByte);
 PROCEDURE _Flush(VAR f:FileOfByte);
 FUNCTION  _FilePos(VAR f:FileOfByte):LONGINT;
 PROCEDURE _Close(VAR f:FileOfByte);
 FUNCTION  _logicalEOF(VAR f:FileOfByte):BOOLEAN;
 FUNCTION  _physicalEOF(VAR f:FileOfByte):BOOLEAN;
 PROCEDURE Resync(VAR f:FileOfByte);
 FUNCTION  _FileSize(VAR f:FileOfByte):LONGINT;
 PROCEDURE _Write(VAR f:FileOfByte; VAR b:BYTE);
 PROCEDURE _Read(VAR f:FileOfByte; VAR b:BYTE);
 PROCEDURE _ReadByte(VAR f:FileOfByte; VAR b:BYTE);
 {
$IFDEF RLE
}
 PROCEDURE RLEcompress(name1,name2:PathStr; VAR fin,fout:FileOfByte; chatty:BOOLEAN);
 {
$ENDIF
}
 PROCEDURE _BlockRead(VAR f:FileOfByte; var buf; count: Word);
 PROCEDURE __BlockRead(VAR f:FileOfByte; var buf; count: Word; VAR result:WORD);
 PROCEDURE _BlockWrite(VAR f:FileOfByte; var buf; count: Word);
 PROCEDURE __BlockWrite(VAR f:FileOfByte; var buf; count: Word; VAR result:WORD);
 PROCEDURE compress(name1,name2:PathStr; chatty:BOOLEAN);
 PROCEDURE decompress(name1,name2:PathStr; chatty:BOOLEAN);

 IMPLEMENTATION
{
$ENDIF
}

CONST ANDMask:ARRAY[0..7] OF BYTE=(254,253,251,247,239,223,191,127);
      OrMask :ARRAY[0..7] OF BYTE=(1,2,4,8,16,32,64,128);
      LowerBits:ARRAY[1..8] OF BYTE=(1,3,7,15,31,63,127,255);
VAR temp:FileOfByte;
    {
$IFDEF test
}
    vorher,nachher,gesamt:LONGINT; 
    ch:CHAR;
    datei1,datei2:PathStr;
    s:STRING;
    {
$ENDIF
}


PROCEDURE WriteBits(VAR f:FileOfByte; wert,Stellen:BYTE);
{
rem: Schreibt das Byte "wert" in die Datei f und benutzt dazu "Stellen" Bits
}
VAR bits:BYTE;
    i,ReallyWritten:WORD;
BEGIN
 IF f.lesen THEN exit;  {
nur Ausgabedateien, bitte!
}
 inc(f.lenbitskom,Stellen);
 IF f.bitzaehl>=Stellen
  THEN BEGIN {
genug Platz in aktuellem Byte f.buf[f.bufIndex]
}
        f.buf[f.bufIndex]:=(f.buf[f.bufIndex] SHL Stellen) OR wert;
        dec(f.bitzaehl,stellen);
        IF f.bitzaehl=0
	 THEN BEGIN {
Byte fertig, ablegen und evtl. Puffer schreiben
}
               inc(f.bufIndex); f.bitzaehl:=8;
               IF f.bufindex>bufSize-1
		THEN BEGIN
                      {
$I-
}
                      BlockWrite(f.datei,f.buf,BufSize,ReallyWritten);
                      {
$IFDEF IOcheck
} {
$I+
} {
$ENDIF
}
                      f.bufIndex:=0;
                      IF IOresult=103
                       THEN BEGIN
                             CompressError:=CompressErr_FileNotOpen;
                             exit
                            END
                      ELSE IF ReallyWritten<>BufSize
                       THEN BEGIN
                             CompressError:=CompressErr_DiskFull;
                             exit
                            END
                      ELSE IF IOresult<>0
                       THEN BEGIN
                             CompressError:=CompressErr_Unknown;
                             exit
                            END;
                     END;
              END;
       END
  ELSE BEGIN {
berhang ins nchste Byte!
}
        bits:=Stellen-f.bitzaehl; {
berhang ins nchste Byte
}
        f.buf[f.bufIndex]:=(f.buf[f.bufIndex] SHL f.bitzaehl) OR (wert SHR bits);
        inc(f.bufIndex);
        IF f.bufindex>bufSize-1
	 THEN BEGIN
               {
$I-
}
               BlockWrite(f.datei,f.buf,BufSize,ReallyWritten);
               {
$IFDEF IOcheck
} {
$I+
} {
$ENDIF
}
               f.bufIndex:=0;
               IF IOresult=103
                THEN BEGIN
                      CompressError:=CompressErr_FileNotOpen;
                      exit
                     END
               ELSE IF ReallyWritten<>BufSize
                THEN BEGIN
                      CompressError:=CompressErr_DiskFull;
                      exit
                     END
               ELSE IF IOresult<>0
                THEN BEGIN
                      CompressError:=CompressErr_Unknown;
                      exit
                     END;
              END;
        f.buf[f.bufIndex]:=wert; f.bitzaehl:=8-bits; {
berhang bernehmen
}
       END;
END;

PROCEDURE ReadBits(VAR f:FileOfByte; VAR wert:BYTE; Stellen:BYTE);
{
rem: Liest "Stellen" Bits aus der Datei f und legt diesen Wert in "wert" ab
}
{
     Dies ist ein rein *physikalisches* Lesen, es werden keine Uminterpre- 
}
{
     tierungen der daten vorgenommen!
}
VAR bits,temp:BYTE;
BEGIN
 inc(f.filebitpos,Stellen);
 IF NOT f.lesen THEN exit;  {
nur Eingabedateien, bitte!
}
 IF f.bitzaehl>=Stellen
  THEN BEGIN {
genug Daten in aktuellem Eingabebyte
}
        wert:=(f.buf[f.bufIndex] SHR (f.bitzaehl-Stellen))
               AND LowerBits[Stellen];
        dec(f.bitzaehl,Stellen);
        IF f.bitzaehl=0
	 THEN BEGIN
               f.bitzaehl:=8;
               inc(f.bufindex);
               IF f.bufIndex=SizeOf(f.buf)
		THEN BEGIN {
nchsten Block lesen
}
                      IF NOT EOF(f.datei)
                       THEN BEGIN
                             BlockRead(f.datei,f.buf,SizeOf(f.buf),f.bufMax);
                             f.bufIndex:=0
                            END
                      {
ELSE f.bufIndex:=512
} {
..um EOF mitzuteilen!
}
                     END;
              END
       END
  ELSE BEGIN {
Daten auch aus nchstem Byte bentigt
}
        bits:=Stellen-f.bitzaehl; {
berhang aus nchstem Byte
}
        temp:=f.buf[f.bufIndex] SHL bits; {
Teil aus altem Byte
}
        inc(f.bufindex);
        IF f.bufIndex=SizeOf(f.buf)
	 THEN BEGIN {
nchsten Block lesen
}
               IF NOT EOF(f.datei)
                THEN BlockRead(f.datei,f.buf,SizeOf(f.buf),f.bufMax);
               f.bufIndex:=0
              END;
        f.bitzaehl:=8-bits;
        wert:=(temp OR (f.buf[f.bufIndex] SHR f.bitzaehl))
               AND LowerBits[Stellen]
       END;
END;

PROCEDURE _Assign(VAR f:FileOfByte; s:STRING);
BEGIN
 assign(f.datei,s)
END;

PROCEDURE ReadHeader(VAR f:FileOfByte);
{
rem: Liest aus der bereits zum lesen geffneten Datei einen evtl. Header aus
}
{
     (und erstellt fr komprimierte Dateien den zugehrigen Codebaum)
}
LABEL break;
VAR i,wert:BYTE;
    help,dummyx:Pbranch;
BEGIN
 FOR i:=0 TO SizeOf(Header)-1 DO f.buf[i]:=0; {
evtl. alte Infos lschen
}
 IF NOT EOF(f.datei)
  THEN BlockRead(f.datei,f.buf,SizeOf(f.buf),f.bufMax)  {
1.Block lesen
}
  ELSE f.bufMax:=0;   {
signalisiere: keine Daten da!
}
 IF f.bufMax
            
...
Expand> <Close

Want complete source code? Download it here

Point(s): 1

Download
0 lines left, continue to read
Sponsored links

File list

Tips: You can preview the content of files by clicking file names^_^
Name Size Date
ANIVGA.DOC220.35 kB07-11-93|18:45
ANIVGA.ENG320.98 kB07-11-93|18:45
ANIVGA.PAS318.61 kB07-11-93|18:45
ANIVGA.TUT12.66 kB07-11-93|18:45
BFFFFFFF.PAS2.02 kB07-11-93|18:45
CHANGES.TXT4.76 kB07-11-93|18:45
COMPRESS.PAS38.98 kB07-11-93|18:45
DATEIEN.PAS45.08 kB07-11-93|18:45
DUMP_SPR.PAS10.05 kB07-11-93|18:45
EINGABEN.PAS8.68 kB07-11-93|18:45
EXAMPL12.PAS3.77 kB07-11-93|18:45
EXAMPLE1.PAS1.58 kB07-11-93|18:45
EXAMPLE2.PAS1.89 kB07-11-93|18:45
EXAMPLE3.PAS3.24 kB07-11-93|18:45
EXAMPLE4.PAS1.64 kB07-11-93|18:45
EXAMPLE5.PAS2.92 kB07-11-93|18:45
EXAMPLE6.PAS3.98 kB07-11-93|18:45
EXAMPLE7.PAS3.03 kB07-11-93|18:45
EXAMPLE8.PAS2.82 kB07-11-93|18:45
EXAMPLE9.PAS1.38 kB07-11-93|18:45
FAQ.TXT11.99 kB07-11-93|18:45
07.00 B
2_HEBREW.FNT3.51 kB11-03-92|10:38
30.FNT3.26 kB11-03-92|10:39
33Q.FNT3.01 kB11-03-92|10:39
36.FNT2.76 kB11-03-92|10:39
44.FNT2.26 kB11-03-92|10:39
8X10.FNT2.51 kB11-03-92|10:38
8X11SNSF.FNT2.76 kB11-03-92|10:38
8X14.FNT3.51 kB11-03-92|10:38
ALPS.FNT3.51 kB11-03-92|10:37
ALPS10.FNT2.51 kB11-03-92|10:37
ALPS11.FNT2.76 kB11-03-92|10:37
ALPS6.FNT1.51 kB11-03-92|10:37
ALPS7.FNT1.76 kB11-03-92|10:37
ALPS8.FNT2.01 kB11-03-92|10:37
ANTIQUE.FNT3.51 kB11-03-92|10:38
APLS9.FNT2.26 kB11-03-92|10:37
B814.FNT3.51 kB11-03-92|10:39
BIGSERIF.FNT3.51 kB11-03-92|10:38
BLCKSNSF.FNT2.51 kB11-03-92|10:38
BLOCK.FNT3.51 kB11-03-92|10:38
BOLD.FNT3.51 kB11-03-92|10:38
BROADWAY.FNT3.51 kB11-03-92|10:38
CNTDOWN.FNT3.51 kB11-03-92|10:37
COMPUTER.FNT3.51 kB11-03-92|10:38
COURIER.FNT3.51 kB11-03-92|10:38
CYRILLIC.FNT3.51 kB11-03-92|10:38
DEFAULT.FNT1.51 kB11-03-92|10:39
FIRE.FNT52.26 kB11-03-92|18:45
FIRE.PAL768.00 B11-03-92|18:45
FRANKFRT.FNT3.51 kB11-03-92|10:37
FRESNO.FNT3.51 kB11-03-92|10:38
FUTURE.FNT3.51 kB11-03-92|10:38
GAELIC.FNT3.51 kB11-03-92|10:37
GEORGIAN.FNT3.51 kB11-03-92|10:37
GREEK.FNT3.51 kB11-03-92|10:38
HOLLOW.FNT3.51 kB11-03-92|10:38
HUGE.FNT4.01 kB11-03-92|10:39
HYLAS.FNT3.51 kB11-03-92|10:38
ITALIC.FNT3.51 kB11-03-92|10:37
ITALICS.FNT3.51 kB11-03-92|10:37
ITT.FNT3.51 kB11-03-92|10:38
LCD.FNT3.51 kB11-03-92|10:38
MEDIEVAL.FNT3.51 kB11-03-92|10:38
MODERNFO.FNT4.01 kB11-03-92|10:39
OCR.FNT3.51 kB11-03-92|10:37
OLDENG.FNT3.51 kB11-03-92|10:37
ROMAN.FNT3.51 kB11-03-92|10:39
SANSERIF.FNT3.51 kB11-03-92|10:39
SCRIBBLE.FNT4.01 kB11-03-92|10:39
SCRIPT.FNT3.51 kB11-03-92|10:37
SCRIPT2.FNT3.51 kB11-03-92|10:39
SENAPL.FNT3.51 kB11-03-92|10:37
SIDE.FNT2.51 kB11-03-92|10:37
SIMILITE.FNT3.51 kB11-03-92|10:39
SMALCAPS.FNT3.51 kB11-03-92|10:39
STRETCH.FNT3.51 kB11-03-92|10:39
SUPER.FNT2.01 kB11-03-92|10:39
THAI.FNT3.51 kB11-03-92|10:39
THIN.FNT3.51 kB11-03-92|10:39
THIN8X8.FNT2.01 kB11-03-92|10:39
_BROADWA.FNT8.01 kB11-02-92|12:06
_OCR.FNT3.51 kB11-03-92|10:39
GRAB.EXE14.53 kB07-11-93|18:45
GRAB.PAS45.71 kB07-11-93|18:45
07.00 B
AEGYPTEN.COD1.30 kB06-12-92|21:42
BLACK.COD434.00 B06-12-92|21:54
FLOWER.COD3.26 kB03-20-92|14:04
FRACTAL.PAL768.00 B07-03-93|16:12
FRACTAL1.PIC62.50 kB07-03-93|16:12
FRACTAL2.PIC62.50 kB07-03-93|16:13
FRACTAL3.PIC62.50 kB07-03-93|16:13
FRACTAL4.PIC62.50 kB07-03-93|16:14
HANTEL.LIB4.77 kB11-10-91|15:20
MARMOR.COD8.80 kB06-13-92|18:38
RANDOM.PAL768.00 B07-17-92|19:31
TILE2.COD1.30 kB10-20-91|13:57
WHATSNEW.LIB1.72 kB06-12-93|20:09
07.00 B
APPLE.COD290.00 B10-02-92|05:34
ESP.COD4.55 kB10-05-92|15:06
GAME.EXE43.13 kB07-04-93|12:21
GAME.PAS12.00 kB07-04-93|13:46
LINE.COD1.02 kB09-25-92|18:55
MUSIC.PAS20.14 kB09-24-92|16:52
MUSIC.TPU4.89 kB07-04-93|12:21
QUEST.LIB4.53 kB10-05-92|15:51
README.TXT549.00 B07-04-93|13:47
SMALLNUM.LIB13.00 kB09-27-92|16:24
SPOOK.LIB3.57 kB10-02-92|07:36
STANDARD.PAL768.00 B09-25-92|18:53
MAKE.BAT165.00 B07-11-93|18:45
MAKES.PAS218.08 kB07-11-93|18:45
PCX2COD.DOC852.00 B07-11-93|18:45
PCX2COD.PAS77.98 kB07-11-93|18:45
README.1ST2.87 kB07-11-93|18:45
README.2ND4.12 kB07-11-93|18:45
SHOWPIC.PAS995.00 B07-11-93|18:45
SVGA256.BGI6.19 kB07-11-93|18:45
UNCHAIN.ASM11.60 kB07-11-93|18:45
UNCHAIN.EXE1.20 kB07-11-93|18:45
UNLIB.PAS5.86 kB07-11-93|18:45
WHATSNEW.EXE37.36 kB07-11-93|18:45
WHATSNEW.PAS9.10 kB07-11-93|18:45
...
Sponsored links

COMPRESS.PAS (678.56 kB)

Need 1 point
Your Point(s)

Your Point isn't enough.

Get point immediately by PayPal

More(Debit card / Credit card / PayPal Credit / Online Banking)

Submit your source codes. Get more point

LOGIN

Don't have an account? Register now
Need any help?
Mail to: support@codeforge.com

切换到中文版?

CodeForge Chinese Version
CodeForge English Version

Where are you going?

^_^"Oops ...

Sorry!This guy is mysterious, its blog hasn't been opened, try another, please!
OK

Warm tip!

CodeForge to FavoriteFavorite by Ctrl+D