谁有压缩字符串的代码，谢谢？

Question

把代码贴出来或发到[email protected]谢谢

Answer 1

一个小巧的数据库压缩算法 　　　康帕斯（中国）国际信息服务有限公司 马文骞 
是这样一件尴尬的事促使我们寻找一种压缩算法：我们刚刚制作完成的欧洲十五国进出口商数据库及其检索系统要占用 700兆空间，它刚好放不到一张光盘上去！ 
常用的压缩工具（如 WinZip 或 ARJ）现在也不起作用，因为我们并不是对整个数据库进行压缩（那样光盘上的数据将无法检索），而只是要将数据库中的某些字段的内容压缩后存入库中——以减少整个数据库占用的空间——然后在使用中动态解压将数据还原为本来面目。 
最理想的办法当然是数据库系统（DBMS）本身直接支持数据压缩存储，但令人遗憾的是：常见的DBMS均未提供该功能。 
在互联网上确实能找到一些有关数据压缩的思想、算法甚至 C语言的部分源代码，但它们大都过于复杂，或应用范围有限（如仅对图像或纯数字数据有效），或是在版权方面有太苛刻的要求。 
最后我们采用了自行设计的算法。该方法的压缩率只有 20%至25% ，但它小巧、容易实现，在实际应用中取得了良好的效果。 
一、算法概述 
压缩冗余的比特位（bit）是常见的压缩思想之一。 
例如，字符串 CCW-2000 的二进制表示为： 
01000011,01000011,01010111,00101101,00110010,00110000,00110000,00110000 
其中每个二进制的前导“0”是冗余的，去掉前导“0”后的表示为： 
1000011,1000011,1010111,101101,110010,110000,110000,110000 
这显然达到了数据压缩的目的，但同时也带来一个很大的问题：二进制流仅仅由“0”和“1”组成，并不存在上面为了表述清晰而加入的“,”。 即：由于压缩后的二进制不再是“定长”的，两个二进制之间如何“划界”成了难题。 
常见的解决方案有：霍夫曼表（Huffman codes）、LZW的动态查询表、Markov的多维长度字典表，以及根据前值和前长度变换应用规则的DAKX方法等。但这些方法大都过于繁杂或未公布技术细节而难以实现。 
为了实现起来简捷，避免用“宰牛刀”，我们设计的算法采用一种折衷的思想：用“缩短”了的“定长”二进制来实现压缩，同时又避免了“划界”的难题。 
具体思路是： 
（1） 所有字符的二进制长度均为 6个 bit而不是一般的 8个 bit。即每个字符节约 2个 bit。这决定了本方法的理想（最高）压缩率为 25%。 
（2） 由于 6个 bit仅能区分64种字符，故将内码小于 127的字符分为“常用”和“不常用”两组。 
（3） 第一组由英文字母（大小写）、0至9的数字、空格以及一个控制字符 
组成；第二组由内码小于 127的其它字符组成。 
（4） 每组内的字符均重新编码，以使其“新内码”均小于64。 
（5） 第二组的每个字符前均以第一组中的控制字符做前缀。 
（6） 内码大于等于 127的字符用普通的 8-bit表示，前缀是两个连续的第一组中的控制字符。 
（7） 本方法显然仅适用于西文文本。 
（8） 压缩后的数据相当于被加密了，这大大提高了信息安全性。 
二、算法实现 
我们制作的西欧进出口商数据库中有大量大段的企业英文描述，故应用上述算法非常成功，如愿以偿地将整个系统的大小降到了 600兆以下，可以轻松地装入一张光盘中。 
检索系统用VB编程，数据库用的是 MS-Access。 
后附程序为清晰起见，将压缩数据库的功能改为压缩文本文件的功能。该程序已在机器上测试通过，可作为一个压缩工具单独运行（为了同时说明压缩及解压缩这两个函数的使用，下面的程序会将刚被压缩的文件再进行解压缩，解压后文件与源文件是完全一样的）。 
附完整的VB源代码： 
Option Explicit 
Dim comped$, comping As String * 1, comping_p%, bit_p& 
Dim ebitmask(1 To 8) As Integer ' 存储掩码的数组 
Sub Command1_Click () 
Dim ibuf$, obuf1$, obuf2$ 
MousePointer = 11 
' 设置掩码 
ebitmask(1) = 128: ebitmask(2) = 64: ebitmask(3) = 32: ebitmask(4) = 16 
ebitmask(5) = 8: ebitmask(6) = 4: ebitmask(7) = 2: ebitmask(8) = 1 
Open "d:\temp\compress\theory.txt" For Input As #1 ' 压缩前的源文件 
Open "d:\temp\compress\theory.6bt" For Output As #2 ' 压缩后的文件 
Open "d:\temp\compress\theory_2.txt" For Output As #3 ' 解压后的文件 
Do While Not EOF(1) 
Line Input #1, ibuf 
obuf1 = DoCompress(ibuf) 
Print #2, obuf1 
obuf2 = UnDoCompress(obuf1) 
Print #3, obuf2 
Loop 
Close #1, #2, #3 
MousePointer = 0 
End Sub 
Function DoCompress (in_buf$) As String ' 对输入的字符串进行压缩 
Dim i&, buf_len&, c As String * 1 
comped = "": comping = Chr(0): comping_p = 0 
buf_len = Len(in_buf) 
If buf_len > 0 Then 
For i = 1 To buf_len 
c = Mid(in_buf, i, 1) 
Select Case c 
Case " ", "A" To "Z", "a" To "z" 
putbits 0, c ' 第一组中的字符 
Case "!" To "/", ":" To "@", "[" To "`", "{" To "~", Chr(1) To Chr(31) 
putbits 1, c ' 第二组中的字符 
Case Else 
putbits 2, c ' 其它字符 
End Select 
Next i 
putbits 3, Chr(0) 
End If 
DoCompress = comped 
End Function 
Sub putbits (flag%, cc$) ' 压缩冗余的比特位(bits) 
Dim i%, c As String * 1 
c = cc 
Select Case flag 
Case 0 '对第一组中的字符内码进行重新定位 
Select Case c 
Case " " 
c = Chr(1) 
Case "0" To "9" 
c = Chr(Asc(c) - 46) 
Case "A" To "Z" 
c = Chr(Asc(c) - 53) 
Case "a" To "z" 
c = Chr(Asc(c) - 59) 
End Select 
Case 1 '对第二组中的字符内码进行重新定位 
Select Case c 
Case "!" To "/" 
c = Chr(Asc(c) - 32) 
Case ":" To "@" 
c = Chr(Asc(c) - 42) 
Case "[" To "`" 
c = Chr(Asc(c) - 68) 
Case "{" To "~" 
c = Chr(Asc(c) - 94) 
Case Chr(1) To Chr(31) 
c = Chr(Asc(c) + 32) 
End Select 
For i = 1 To 6 
putbit 0 
Next i 
Case 2 
For i = 1 To 12 
putbit 0 
Next i 
For i = 1 To 8 
If (Asc(c) And ebitmask(i)) <> 0 Then 
putbit 1 
Else 
putbit 0 
End If 
Next i 
Case 3 
For i = comping_p + 1 To 9 
putbit 0 
Next i 
End Select 
If flag < 2 Then 
For i = 1 To 6 
If (Asc(c) And ebitmask(i + 2)) <> 0 Then 
putbit 1 
Else 
putbit 0 
End If 
Next i 
End If 
End Sub 
Sub putbit (bit%) ' 设置比特位(bit) 
comping_p = comping_p + 1 
If comping_p > 8 Then 
comped = comped + comping 
comping = Chr(0) 
comping_p = 1 
End If 
If bit = 1 Then 
comping = Chr(Asc(comping) Or ebitmask(comping_p)) 
End If 
End Sub 
Function UnDoCompress (in_buf$) As String ' 对输入的字符串进行解压缩 
Dim bits_buf%, out_buf$, c As String * 1, comped_len& 
comped = in_buf: bit_p = 1: comped_len = Len(comped) * 8 
Do While bit_p <= comped_len 
If comped_len - bit_p < 5 Then 
Exit Do 
End If 
bits_buf = getbits(6) 
If bits_buf <> 0 Then ' 根据控制字符判断字符的组别 
Select Case bits_buf 
Case 1 
c = " " 
Case 2 To 11 ' "0" To "9" 
c = Chr(bits_buf + 46) 
Case 12 To 37 ' "A" To "Z" 
c = Chr(bits_buf + 53) 
Case 38 To 63 ' "a" To "z" 
c = Chr(bits_buf + 59) 
End Select 
out_buf = out_buf + c 
Else 
If bit_p > comped_len Then 
Exit Do 
End If 
bits_buf = getbits(6) 
If bits_buf <> 0 Then 
Select Case bits_buf 
Case 1 To 15 ' "!" To "/" 
c = Chr(bits_buf + 32) 
Case 16 To 22 ' ":" To "@" 
c = Chr(bits_buf + 42) 
Case 23 To 28 ' "[" To "`" 
c = Chr(bits_buf + 68) 
Case 29 To 32 ' "{" To "~" 
c = Chr(bits_buf + 94) 
Case 33 To 63 ' Chr(1) To Chr(31) 
c = Chr(bits_buf - 32) 
End Select 
out_buf = out_buf + c 
Else 
bits_buf = getbits(8) 
out_buf = out_buf + Chr(bits_buf) 
End If 
End If 
Loop 
UnDoCompress = out_buf 
End Function 
Function getbits (numb As Integer) As Integer ' 获取比特位(bit) 
Dim byte_p&, bit_o%, byte1 As String * 1, i%, j%, k%, m% 
byte_p = (bit_p \ 8) + 1: bit_o = bit_p Mod 8 
byte1 = Mid(comped, byte_p, 1): j = 0: k = 0 
For i = bit_o To 8 
k = k + 1 
If k > numb Then 
Exit For 
End If 
If (Asc(byte1) And ebitmask(i)) <> 0 Then 
j = j Or ebitmask(IIf(numb = 6, k + 2, k)) 
End If 
Next i 
If k < numb Then 
byte1 = Mid(comped, byte_p + 1, 1): m = numb - k 
For i = 1 To m 
k = k + 1 
If (Asc(byte1) And ebitmask(i)) <> 0 Then 
j = j Or ebitmask(IIf(numb = 6, k + 2, k)) 
End If 
Next i 
End If 
bit_p = bit_p + numb 
getbits = j 
End Function 
Sub Command2_Click () 
End 
End Sub 

Answer 2

LZ77/78、LZW类（Zip、Rar、Ace……）的算法压缩字符串比较好
你找找专业文献就行了楼上的代码速度慢是由于它不熟悉位运算
居然用字符串模拟
速度不慢才怪可参考（原理一致）：
http://expert.csdn.net/Expert/topic/2678/2678692.xml?temp=.8718988
本代码演示了如何在网络上不保存文件到硬盘而传送图像。
http://www.fantasiasoft.net/SpyScreen.zip