En enhet å komprimere LZW filer
bidragsyter: IAN HUNTER plakater (* Fra: IAN HUNTER subj: LZW komprimering Unit *)
Unit IHLZW; {- Unit for å håndtere datakomprimering} Interface Const Stackoverflow = 1; DeniedWrite = 2; Skriv GetCharFunc = Function (Var Ch: Char): Boolean; PutCharProc = Prosedyre (Ch: Char); LZW = Objekt getchar: GetCharFunc; Putchar: PutCharProc; LastError: Word; Constructor Init; Funksjon Get_Hash_Code (PrevC, FollC: Integer): Integer; Prosedyre Make_Table_Entry (PrevC, FollC: Integer); Prosedyre Initialize_String_Table; Prosedyre Initial; Funksjon Lookup_String (PrevC, FollC: Integer): Integer; Prosedyre Get_Char (Var C: Integer); Prosedyre Put_Char (C: Integer); Prosedyre Compress; Prosedyre dekomprimere; Enden,
Implementering Const MaxTab = 4095; No_Prev = $ 7FFF; EOF_Char = -2; End_list = 1; Empty = -3;
Type AnyStr = String; String_Table_Entry = Vanlig brukt: Boolean; PrevChar: Integer; FollChar: Integer; Neste: Integer; Enden,
Var String_Table: Array [0..MaxTab] Of String_Table_Entry; Table_Used: Integer; Utdatakode: Integer; Inndatakode: Integer; If_Compressing: Boolean;
Constructor LZW.Init; Begynn LastError: = 0; Enden,
Function LZW.Get_Hash_Code (PrevC, FollC: Integer): Integer; Var indeks: Integer; Indeks2: Integer; Begynn indeks: = ((PrevC SHL 5) XOR FollC) OG MaxTab; Hvis (Ikke String_Table [Indeks] .Used) Så Get_Hash_Code: = Index Else Begynn Mens (String_Table [Indeks] .Neste < > end_list) Gjør indeks: = String_Table [Indeks] .Neste; Indeks2: = (indeks + 101) Og MaxTab; Mens (String_Table [Indeks2] .Used) Gjør Indeks2: = succ (Indeks2) OG MaxTab; String_Table [Indeks] .Neste: = Indeks2; Get_Hash_Code: = Indeks2; Avslutt; Enden,
Prosedyre LZW.Make_Table_Entry (PrevC, FollC: Integer); Begynner Hvis (Table_Used < = MaxTab) Deretter starter med String_Table [Get_Hash_Code (PrevC, FollC)] Har Begin Brukt: = True; Neste: = end_list; PrevChar: = PrevC; FollChar: = FollC; Avslutt; Inc (Table_Used); (* IF (Table_Used > (MaxTab + 1)), og start WRITELN ( 'Hash bord fullt.'); END; *) End; Enden,
Prosedyre LZW.Initialize_String_Table; Var jeg: Integer; Begynn Table_Used: = 0; For jeg: = 0 til MaxTab gjøre med String_Table [I] Har Begynn PrevChar: = No_Prev; FollChar: = No_Prev; Neste: = -1; Brukt: = False; Avslutt; For jeg: = 0 til 255 Do Make_Table_Entry (No_Prev, jeg); Enden,
Prosedyre LZW.Initialize; Begynn utdatakode: = Tom; Inndatakode: = Tom; Initialize_String_Table; Enden,
Function LZW.Lookup_String (PrevC, FollC: Integer): Integer; Var indeks: Integer; Indeks2: Integer; Funnet: Boolean; Begynn indeks: = ((PrevC Shl 5) Xor FollC) Og MaxTab; Lookup_String: = end_list; Gjenta Funnet: = (String_Table [Indeks] .PrevChar = PrevC) og (String_Table [Indeks] .FollChar = FollC); Hvis (Not Found) Så indeks: = String_Table [Indeks] .Neste; Inntil Funnet Eller (indeks = end_list); Hvis Funnet Deretter Lookup_String: = Indeks; Enden,
Prosedyre LZW.Get_Char (Var C: Integer); Var Ch: Char; Begynn Hvis ikke getchar (Ch) Deretter C: = EOF_Char Else C: = Ord (Ch); Enden,
Prosedyre LZW.Put_Char (C: Integer); Var Ch: Char; Begynne Ch: = Chr (C); Putchar (Ch); Enden,
Prosedyre LZW.Compress; Prosedyre Put_Code (Hash_Code: Integer); Begynner Hvis (utdatakoden = Tom) Deretter begynner Put_Char ((Hash_Code SHR 4) Og $ FF); Utdatakode: = Hash_Code Og $ 0F; Avslutt Else Begynn Put_Char (((utdatakoden Shl 4) Og $ FF0) + ((Hash_Code SHR 8) Og $ 00F)); Put_Char (Hash_Code Og $ FF); Utdatakode: = Tom; Avslutt; Enden,
Prosedyre Do_Compression; Var C: Integer; WC: Integer; W: Integer; Begynn Get_Char (C); W: = Lookup_String (No_Prev, C); Get_Char (C); Mens (C < > EOF_Char) Gjør Begynn WC: = Lookup_String (W, C); Hvis (WC = end_list), og start Make_Table_Entry (W, C); Put_Code (W); W: = Lookup_String (No_Prev, C); Avslutt Else W: = WC; Get_Char (C); Avslutt; Put_Code (W); Enden,
Begynn If_Compressing: = True; initial~~POS=TRUNC; Do_Compression; Enden,
Prosedyre LZW.Decompress; Const MaxStack = 4096; Var Stack: Array [1..MaxStack] Of Integer; Stack_Pointer: Integer;
Prosedyre Push (C: Integer); Begynn Inc (Stack_Pointer); Stack [Stack_Pointer]: = C; Hvis (Stack_Pointer > = MaxStack), og start LastError: = 1; exit; Avslutt; Enden,
Prosedyre Pop (Var C: Integer); Begynn; Hvis (Stack_Pointer > 0), og start C: = Stack [Stack_Pointer]; Desember (Stack_Pointer); Avslutt Else C: = Tom; Enden,
Prosedyre Get_Code (Var Hash_Code: Integer); Var Local_Buf: Integer; Begynner Hvis (inndatakode = Tom) Deretter begynner Get_Char (Local_Buf); Hvis (Local_Buf = EOF_Char), og start Hash_Code: = EOF_Char; exit; Avslutt; Get_Char (inndatakode); Hvis (inndatakode = EOF_Char), og start Hash_Code: = EOF_Char; exit; Avslutt; Hash_Code: = ((Local_Buf Shl 4) Og $ FF0) + ((inndatakode SHR 4) Og $ 00F); Inndatakode: = inndatakode Og $ 0F; Avslutt Else Begynn Get_Char (Local_Buf); Hvis (Local_Buf = EOF_Char), og start Hash_Code: = EOF_Char; exit; Avslutt; Hash_Code: = Local_Buf + ((inndatakode Shl 8) Og $ F00); Inndatakode: = Tom; Avslutt; Enden,
Prosedyre Do_Decompression; Var C: Integer; Kode: Integer; Old_Code: Integer; Fin_Char: Integer; In_Code: Integer; Last_Char: Integer; Unknown: Boolean; Temp_C: Integer; Begynn Stack_Pointer: = 0; Unknown: = False; Get_Code (Old_Code); Kode: = Old_Code; C: = String_Table [kode] .FollChar; Put_Char (C); Fin_Char: = C; Get_Code (In_Code); Mens (In_Code < > EOF_Char) Gjør Begynn Kode: = In_Code; Hvis (Ikke String_Table [kode] .Used), og start Last_Char: = Fin_Char; Kode: = Old_Code; Unknown: = true; Avslutt; Mens (String_Table [kode] .PrevChar < > No_Prev) gjøre med String_Table [kode] Har Begynn Push (FollChar); Hvis (LastError < > 0) Then Exit; Kode: = PrevChar; Avslutt; Fin_Char: = String_Table [kode] .FollChar; Put_Char (Fin_Char); Pop (Temp_C); Mens (Temp_C < > Tom) Har Begynn Put_Char (Temp_C); Pop (Temp_C); Avslutt; Hvis Ukjent deretter begynne Fin_Char: = Last_Char; Put_Char (Fin_Char); Unknown: = false; Avslutt; Make_Table_Entry (Old_Code, Fin_Char); Old_Code: = In_Code; Get_Code (In_Code); Avslutt; Enden,
Begynn If_Compressing: = False; initial~~POS=TRUNC; Do_Decompression; Slutt;.
End product: (* ***************************** TEST PROGRAM ******* *********** *)
Program LZWTest; {Program til demo /teste LZW objektet} Bruker IHLZW; {Bare trenger denne} Var C: LZW; {The Star of the Show; Komprimering Object} product: {$ F +} Funksjon GetTheChar (Var Ch: Char): Boolean; {$ F-} {Gjør din getchar rutine erklæring ser akkurat ut som dette}
begynner Hvis ikke EOF (Input) {End of Input? } Så Begynn Read (Input, Ch); {Les deretter ett tegn til Ch og ...} GetTheChar: = True; {... Return true} End Else GetTheChar: = False; {Ellers return false} End, product: {$ F +} Prosedyre PutTheChar (Ch: Char); {$ F-} {Gjør din putchar rutine erklæring ser akkurat ut som dette}
Begynn Skriv (Output, Ch); {Skriv Ch til Output file} End,
Begynn {Åpne datafiler} Assign (Input, ''); {Standard Input; krever omdirigering til å være nyttig} tildele (Output, ''); {Standard Output; krever omdirigering til å være nyttig} Reset (Input); Omskriving (Output); {Kan ikke svikte ennå - kanskje en etterkommer kunne, men ...} Hvis ikke C.Init Så Halt; {Tilordne I /O-rutiner} C.GetChar: = GetTheChar; {Set LZW er getchar til rutine GetTheChar} C.PutChar: = PutTheChar; {Set LZW er putchar til rutine PutTheChar} {vi komprimere eller dekomprimere? } Hvis (ParamCount = 0) Så C.Compress {komprimere} Else C.Decompress; {Dekomprimere} {All Ferdig! } End.