Çok Yakında Yeni Bir Arayüzle karşınızdayız! http://yeni.delphican.com/

Konuyu Oyla:
  • Derecelendirme: 5/5 - 1 oy
  • 1
  • 2
  • 3
  • 4
  • 5
Delphi LZW Algoritması
#1
Merhaba,

İhtiyaç gereği LZW algoritması kullanmam gerekti. Diğer dillerde internet üzerinde pek çok örnek kod varken Delphi'de elle tutulur bir şey göremedim. İhtiyaç dahilinde yazdım birilerinin işini görür diye paylaşıyorum.

LZW algoritması nedir?
Lempel, Ziv ve Welch tarafından geliştirilmiş kayıpsız sıkıştırma algoritmalarından birisidir. Karşılaşılan karakter grupları bir tabloda tutularak aynı karakter grupları ile karşılaşıldığında sadece tablodaki numarası yazılarak veri kısaltılmış olur... Merak eden arkadaşlarımız devamını araştırabilir.

Linkleri Görebilmeniz İçin Üye Olmanız Gerekiyor. Üye Olabilmek İçin Lütfen Buraya Tıklayınız.

lQL3BX.png 

P7pnqd.png

unit LZWLib;

{****************************
 LZWLib.pas 2019
 Salih BAĞCI
*****************************}

interface

 uses SysUtils, System.Classes;

 type
   TLZWEncodeResult = record
   EncodeString     : String;
   SozcukList       : String;
 end;

 type
   TLZWDecodeResult = record
   DecodeString     : String;
   SozcukList       : String;
 end;

 type
   TMultiArray = array of array of String;

 function IntegerArrayIndexOf(const AArray:TMultiArray;const ASearch:String):Integer;
 function StringArrayIndexOf(const AArray:TMultiArray;const ASearch:String):Integer;
 function EncodeLZW(const AValue: String):TLZWEncodeResult;
 function DecodeLZW(const AValue: String):TLZWDecodeResult;

 const EncodeAyrac = '-';
 const ASCII_BEGIN = 400;

implementation

function IntegerArrayIndexOf(const AArray: TMultiArray; const ASearch: String): Integer;
Var
 Ind : Integer;
begin
 Result := -1;
 for Ind := Low(AArray) to High(AArray) do
   if AArray[Ind][1] = ASearch then
     Exit(Ind);
end;

function StringArrayIndexOf(const AArray: TMultiArray; const ASearch: String): Integer;
Var
 Ind : Integer;
begin
 Result := -1;
 for Ind := Low(AArray) to High(AArray) do
   if AArray[Ind][0] = ASearch then
     Exit(Ind);
end;

function DecodeLZW(const AValue: String): TLZWDecodeResult;
Var
 xSozcukArray  : TMultiArray;
 xSozcukKonumN : Integer;
 xSozcukLength : Integer;
 Ind           : Integer;
 xValueList    : TStringList;
 OLD           : String;
 NEW           : String;
 S,C           : String;
 ASCII         : Integer;
begin
 if AValue = '' then
   Exit;
 Result.DecodeString := '';
 Result.SozcukList   := '';
 xSozcukLength       := 0;
 ASCII               := ASCII_BEGIN;

 xValueList := TStringList.Create;
 with xValueList do
 begin
   BeginUpdate;
   Text := AValue;
   Text := StringReplace(Text,EncodeAyrac,sLineBreak,[rfReplaceAll]);
   EndUpdate;
 end;

 try
   for Ind := 0 to Pred(xValueList.Count) do
   begin
     if StrToInt(xValueList[Ind]) < ASCII_BEGIN + 1 then
     begin
       Inc(xSozcukLength);
       SetLength(xSozcukArray,xSozcukLength,2);
       xSozcukArray[Pred(xSozcukLength)][0] := Char(StrToInt(xValueList[Ind]));
       xSozcukArray[Pred(xSozcukLength)][1] := xValueList[Ind];
     end;
   end;

   OLD                 := Char(StrToInt(xValueList[0]));
   Result.DecodeString := OLD;
   C                   := '';

   for Ind := 1 to Pred(xValueList.Count) do
   begin
     NEW           := xValueList[Ind];
     xSozcukKonumN := IntegerArrayIndexOf(xSozcukArray,NEW);
     if xSozcukKonumN = -1 then
     begin
       S := OLD;
       S := S + C;
     end
     else
       S := xSozcukArray[xSozcukKonumN][0];

     Result.DecodeString := Result.DecodeString + S;
     C                   := S[1];

     Inc(xSozcukLength);
     Inc(ASCII);
     SetLength(xSozcukArray,xSozcukLength,2);
     xSozcukArray[Pred(xSozcukLength)][0] := OLD + C;;
     xSozcukArray[Pred(xSozcukLength)][1] := IntToStr(ASCII);
     Result.SozcukList                    := Result.SozcukList + OLD + C + ' : ' + IntToStr(ASCII) + sLineBreak;
     OLD                                  := S;
   end;
 finally
   FreeAndNil(xValueList);
 end;
end;

function EncodeLZW(const AValue: String): TLZWEncodeResult;
Var
 xSozcukArray   : TMultiArray;
 xSozcukLength  : Integer;
 xSozcukKonumPC : Integer;
 xSozcukKonumP  : Integer;
 Ind            : Integer;
 P              : String;
 C              : Char;
 ASCII          : Integer;
begin
 if AValue = '' then
   Exit;
 Result.EncodeString := '';
 Result.SozcukList   := '';
 xSozcukLength       := 0;
 ASCII               := ASCII_BEGIN;

 for Ind := Low(AValue) to High(AValue) do
 begin
   if StringArrayIndexOf(xSozcukArray,AValue[Ind]) = -1 then
   begin
     Inc(xSozcukLength);
     SetLength(xSozcukArray,xSozcukLength,2);
     xSozcukArray[Pred(xSozcukLength)][0] := AValue[Ind];
     xSozcukArray[Pred(xSozcukLength)][1] := IntToStr(Ord(AValue[Ind]));
   end;
 end;

 P := AValue[1];
 for Ind := Succ(Low(AValue)) to High(AValue) do
 begin
   C := AValue[Ind];
   xSozcukKonumPC := StringArrayIndexOf(xSozcukArray,P + C);
   if xSozcukKonumPC <> -1 then
     P := P + C
   else
   begin
     xSozcukKonumP       := StringArrayIndexOf(xSozcukArray,P);
     Result.EncodeString := Result.EncodeString + xSozcukArray[xSozcukKonumP][1] + EncodeAyrac;

     Inc(xSozcukLength);
     Inc(ASCII);
     SetLength(xSozcukArray,xSozcukLength,2);
     xSozcukArray[Pred(xSozcukLength)][0] := P + C;
     xSozcukArray[Pred(xSozcukLength)][1] := IntToStr(ASCII);
     Result.SozcukList                    := Result.SozcukList + P + C + ' : ' + IntToStr(ASCII) + sLineBreak;

     P := C;
   end;
 end;
 xSozcukKonumP       := StringArrayIndexOf(xSozcukArray,P);
 Result.EncodeString := Result.EncodeString + xSozcukArray[xSozcukKonumP][1];
end;

end.
Yalnızım ama bir kente yürüyen ordu gibiyim, edebiyattan kaçınmalıyım..
Cevapla
#2
Elinize saglik
Cevapla
#3
Teşekkürler @narkotik
Cevapla


Konu ile Alakalı Benzer Konular
Konular Yazar Yorumlar Okunma Son Yorum
  Delphi'de Indy SMTP ile e-mail gönderme. (GMail, Yandex, Yahoo vb.) csunguray 15 3.618 26-06-2019, Saat: 13:59
Son Yorum: csunguray
  Delphi ve Protocol Buffers SimaWB 6 1.028 28-05-2019, Saat: 10:20
Son Yorum: klavye
  Delphi'de BreakPoint (durma noktası) işaretinin yanlış satırda görünmesi csunguray 1 660 17-12-2018, Saat: 00:40
Son Yorum: Bay_Y
  Delphi IDE'sine Eklenti Yapmak - 2 SimaWB 27 5.076 04-12-2018, Saat: 10:25
Son Yorum: ssahinoglu
  Delphi'de Inno Setup | Sorgulu Uninstall İşlemi Halil Han Badem 13 2.030 17-11-2018, Saat: 19:50
Son Yorum: sabanakman



Konuyu Okuyanlar: 1 Ziyaretçi