RHS 09Spt2004
LZ77 compression is a precursor to LZW compression (An LZW-compressing virtual filesystem), I believe. When working on the Binary image compression challenge, I became interested in writing a pure-tcl implementation of gzip. As gzip uses LZ77 (and Huffman encoding), I decided to start by implementing such an algorithm. Sadly, its spectacularly slow, so its not worthwhile in its present form. I figured it would be worth posting, however, in case anyone wanted to play with it.
# #############################################
# FILE: lz77.tcl - the code for the compression
namespace eval lz77 {
variable lookback 255
variable Escape1 "\x01"
variable Escape2 "\x02"
variable EscEsc "\x01"
set K32 [expr {32 * 1024}]
}
proc ::lz77::K {a b} { return $a }
proc ::lz77::encode {data} {
variable Escape1
variable Escape2
variable EscEsc
variable K32
set output ""
set dataLength [string length $data]
append output [string index $data 0]
for {set i 1} {$i < $dataLength} {incr i} {
set foundAt 0
set foundLen 0
set found [maxSubstring $i $data length offset]
if { $length > 0 } {
if { $offset < 255 & $foundLen < 255 } {
set offChar [format %c $offset]
set lenChar [format %c $length]
append output $Escape1$lenChar$offChar
incr i $length
incr i -1
} else {
append output $Escape2
append output [binary format S $length]
append output [binary format S $offset]
incr i $length
incr i -1
}
} else {
set char [string index $data $i]
if { [string equal $char "$Escape1"] } {
append output "$Escape1$EscEsc"
} else {
append output $char
}
}
}
return $output
}
proc ::lz77::decode {data} {
variable Escape1
variable Escape2
variable EscEsc
set output ""
for {set i 0} {$i < [string length $data]} {incr i} {
set char [string index $data $i]
if { ($char ne "$Escape1") && ($char ne "$Escape2") } {
append output $char
} elseif { [string index $data [expr {$i + 1}]] eq "$EscEsc" } {
append output $char
incr i
} else {
if { $char eq $Escape1 } {
scan [string index $data [incr i]] %c length
scan [string index $data [incr i]] %c offset
set index [expr {[string length $output] - $offset}]
for {set j 0} {$j < $length} {incr j} {
append output [string index $output $index]
incr index
}
} else {
binary scan [string range $data [incr i] [incr i]] S length
binary scan [string range $data [incr i] [incr i]] S offset
set index [expr {[string length $output] - $offset}]
for {set j 0} {$j < $length} {incr j} {
append output [string index $output $index]
incr index
}
}
}
}
return $output
}
proc ::lz77::maxSubstring {index data &matchLength &matchOffset} {
upvar ${&matchLength} matchLength
upvar ${&matchOffset} matchOffset
variable K32
set matchLength 0
set matchOffset 0
if { $index > $K32 } {
set data [string range [K $data [unset data]] [expr {$index - $K32}] end]
set index $K32
}
set dataLength [string length $data]
set string [string range $data $index end]
if { [string length $string] >= $K32 } {
set string [string range $string 0 [expr {$K32 -2}]]
}
# If data is > 32k, get the part we need
if { $index > $K32 } {
set start [expr {$index - $K32}]
} else {
set start 0
}
if { $dataLength > ($index + $K32) } {
set end [expr {$index + $K32}]
} else {
set end end
}
set currData [string range $data $start $end]
while {[string length $string] >= 3} {
set first 0
while {
([set first [string first $string $currData $first]] >= 0)
} {
if { $first < $index } {
set len [string length $string]
if { ($index - $first) > 255 && $len < 5 } {
} else {
if { $len > $matchLength } {
set matchOffset [expr {$index - $first}]
set matchLength $len
}
}
} else {
if { $first > $index } {
break
}
}
incr first
}
if { $matchLength > 0 } {
return 1
}
set string [string range $string 0 end-1]
if { ([string length $string] + $index) > [string length $currData] } {
set currData [string range [K $currData [unset currData]] \
[expr {$index + [string length $string]}]]
}
}
return 0
}And, the tests...
# #############################################
# FILE: lz77.test - tests for lz77
package require tcltest
namespace import tcltest::*
source [file join [file dirname [info script]] gz.tcl]
# ========================================
test encode-1.1 {
encode a simple string in using LZ77
} -body {
set encoded [::lz77::encode {abcdebcdef}]
set expect "abcde\x01\x04\x04"
append expect f
if { [string length $expect] != [string length $encoded] } {
binary scan $expect c* exList
binary scan $encoded c* enList
puts "ENCODED: $exList -> $enList"
return "String lengths were not the same: \
[string length $expect] != [string length $encoded]"
}
if { ![string equal $expect $encoded] } {
binary scan $expect c* exList
binary scan $encoded c* enList
puts "EXPECTED: $exList\nENCODED : $enList"
return "Strings were not equal"
}
} -result {}
test encode-1.2 {
encode a simple string in using LZ77
} -body {
set encoded [::lz77::encode {Blah blah blah blah blah!}]
set expect "Blah b\x01\x12\x05!"
if { [string length $expect] != [string length $encoded] } {
return "String lengths were not the same: \
[string length $expect] != [string length $encoded]"
}
if { ![string equal $expect $encoded] } {
return "Strings were not equal"
}
} -result {}
test encode-1.3 {
encode a string with multiple matches
} -body {
set string {This is a string with multiple strings within it}
set expect "This \x01\x03\x03"
append expect "a string with multiple\x01\x07\x15"
append expect "s\x01\x05\x16"
append expect "in it"
set encoded [::lz77::encode $string]
if { [string length $expect] != [string length $encoded] } {
binary scan $expect c* exList
binary scan $encoded c* enList
puts "EXPECT: $exList"
puts "ENCODE: $enList"
return "String lengths were not the same: \
[string length $expect] != [string length $encoded]"
}
if { ![string equal $expect $encoded] } {
binary scan $expect c* exList
binary scan $encoded c* enList
puts "EXPECT: $exList"
puts "ENCODE: $enList"
return "Strings were not equal"
}
} -result {}
test encode-1.4 {
Encode a long (>255 <255*255) string, to use second escape
} -setup {
set original "abcdefghij"
for {set i 0} {$i < 254} {incr i} {
append original [expr {$i % 10}]
}
append original "abcdefg"
set expect "abcdefghij0123456789"
append expect "\x01\xF4\x0a"
append expect "\x02\x00\x07\x01\x08"
} -body {
set encoded [::lz77::encode $original]
if { ![string equal $expect $encoded] } {
binary scan $expect c* exList
binary scan $encoded c* enList
puts "EXPECT: $exList"
puts "ENCODE: $enList"
return "Strings were not equal"
}
} -result {}
# ========================================
test decode-1.1 {
decode a simple string using LZ77
} -body {
set decoded [::lz77::decode "Blah b\x01\x12\x05!"]
set expect {Blah blah blah blah blah!}
if { [string length $expect] != [string length $decoded] } {
puts "$expect != $decoded"
return "String lengths were not the same: \
[string length $expect] != [string length $decoded]"
}
if { ![string equal $expect $decoded] } {
puts "$expect != $decoded"
return "Strings were not equal"
}
} -result {}
# ========================================
test cycle-1.1 {
cycle a string through encode and decode
} -body {
set original "This is a string with multiple strings within it"
set encoded [::lz77::encode $original]
set changed [::lz77::decode $encoded]
if { ![string equal $original $changed] } {
puts "Not Equal:\nORIGINAL: $original\nENCODED : $changed"
binary scan $encoded c* enList
puts $enList
return "The strings were not equal"
}
return
} -result {}
test cycle-1.2 {
cycle a string through encode and decode
} -body {
set original "This is a string of text, \
whereherehereherehe parts of the string\
have text that is in other parts of the string"
set encoded [::lz77::encode $original]
set changed [::lz77::decode $encoded]
if { ![string equal $original $changed] } {
puts "Not Equal:\nORIGINAL: $original\nENCODED : $changed"
binary scan $encoded c* enList
puts $enList
return "The strings were not equal"
}
return
} -result {}
test cycle-1.3 {
Encode a long (>255 <255*255) string, to use second escape\
and decode it
} -setup {
set original "abcdefghij"
for {set i 0} {$i < 254} {incr i} {
append original [expr {$i % 10}]
}
append original "abcdefg"
} -body {
set encoded [::lz77::encode $original]
set decoded [::lz77::decode $encoded]
if { ![string equal $original $decoded] } {
binary scan $original c* orList
binary scan $decoded c* deList
puts "ORIGINAL: $orList"
puts "DECODED : $deList"
return "Strings were not equal"
}
} -result {}
# ========================================
# Special cases
# When there's an escape in the input text
# Encode it as \x01\x01, since we can't have a repeat length of 1
test escape-1.1 {
An escape in the input data is coded as the escape, followed\
by \x01
} -setup {
unset -nocomplain original expect encoded exList enList
} -body {
set original "ab\x01" ; append original cd
set expect "ab\x01\x01" ; append expect cd
set encoded [::lz77::encode $original]
if { ![string equal $expect $encoded] } {
binary scan $expect c* exList
binary scan $encoded c* enList
puts "$exList ->\n$enList"
return "The strings were not equal"
}
} -result {}
test escape-1.2 {
An escape in the input data is coded as the escape, followed\
by \x01
} -setup {
unset -nocomplain original expect encoded exList enList
} -body {
set original "ab\x01" ; append original cd
set encoded [::lz77::encode $original]
set decoded [::lz77::decode $encoded]
if { ![string equal $original $decoded] } {
binary scan $original c* orList
binary scan $decoded c* deList
puts "$orList ->\n$deList"
return "The strings were not equal"
}
} -result {}
test escape-1.2 {
An escaped escape should not interfere with runs surrounding it
} -setup {
unset -nocomplain original expect encoded exList enList
} -body {
set original "abcdebcde\x01" ; append original cd
set expect "abcde\x01\x04\x04\x01\x01" ; append expect cd
set encoded [::lz77::encode $original]
if { ![string equal $expect $encoded] } {
binary scan $expect c* exList
binary scan $encoded c* enList
puts "$exList ->\n$enList"
return "The strings were not equal"
}
} -result {}
# If there's multiple matches, get the longest one possible
# "These blah is blah blah blah!"
# ^ the match for here
# ^ should start here
# ^ not here
test longest-1.1 {
Get the longest match possible
} -setup {
unset -nocomplain original expect encoded exList enList
set original {These blah is blah blah blah!}
set expect "These blah is\x01\x06\x08"
append expect "\x01\x09\x05!"
} -body {
set encoded [::lz77::encode $original]
if { ![string equal $expect $encoded] } {
binary scan $expect c* exList
binary scan $encoded c* enList
puts "Expect: $exList ->\nEncode: $enList"
puts "DECODE: [::lz77::decode $encoded]"
return "The strings were not equal"
}
} -result {}
# ========================================
test maxSubstring-1.1 {
Find the max substring for a string with only one match
} -setup {
unset -nocomplain length offset
set string {abcdefcdefg}
set index 6
} -body {
set flag [::lz77::maxSubstring $index $string length offset]
list $flag $length $offset
} -result {1 4 4}
test maxSubstring-1.2 {
Return 0 if no match
} -setup {
unset -nocomplain length offset
set string {abcdefghijk}
set index 6
} -body {
::lz77::maxSubstring $index $string length offset
} -result {0}
test maxSubstring-1.3 {
Find the max substring for a string with multiple matches
} -setup {
unset -nocomplain length offset
set string {aaaabbbbaaaaaaaa}
set index 9
} -body {
set flag [::lz77::maxSubstring $index $string length offset]
list $flag $length $offset
} -result {1 7 1}
test maxSubstring-1.4 {
For a very long string (>32k), remove everything 32k \
past the index
} -setup {
unset -nocomplain length offset
set original "abcdef"
for {set i 0} {$i < 1024} {incr i} {
append original "0123456789012345678901234567890123456789"
}
append original "abcdef"
set index 17
} -body {
set flag [::lz77::maxSubstring $index $original length offset]
list $flag $length $offset
} -result {1 32767 10}
test maxSubstring-1.5 {
For a very long string (>32k), remove anything more than 32k\
before the index
} -setup {
unset -nocomplain length offset
set original "abcdef"
for {set i 0} {$i < 1024} {incr i} {
append original "0123456789012345678901234567890123456789"
append original "0123456789012345678901234567890123456789"
append original "0123456789012345678901234567890123456789"
}
append original "abcdef"
set index 40000
} -body {
set flag [::lz77::maxSubstring $index $original length offset]
list $flag $length $offset
} -result {1 32767 32760}
# ========================================
cleanupTestsPS 10Sep04: This brings us terribly close to pure tcl deflate/gzip. Reading http://www.gzip.org/deflate.html suggests that the Huffman coding is not terribly hard to do.
DKF: I'd estimate that the easiest way to speed this up would be to make [maxSubstring] return a list of its three result values instead of using upvar. Splitting the result list with foreach or lassign is much faster...
MS The usage of [K] can also be sped up noticeably: use the idiom [K $x [set x {}]]] instead of [K $x [unset x]]]. Even faster is the bytecompiled variant [lindex [list $x [set x{}]]] 0]. Which reminds me ... soon (?) to be the fastest is the plain $x[set x {}] - as soon as I get around to implementing FRE 924097 (optimise {}-appends [L1 ]) This optimisation has been committed to HEAD on 2004-09-10 (8.5a2)
Peter Spjuth: Is it intentional that maxSubstring prefers the earliest match? I would think that minimizing offset by prefering the latest match would be better. That would make a more efficient solution possible using [string last]. Also, is K really useful with [string range]?
RHS To add some comments...
The new maxSubstring function (I'll update it later to use 'string last' instead of 'string first')
proc ::lz77::maxSubstring {index data &matchLength &matchOffset} {
upvar ${&matchLength} matchLength
upvar ${&matchOffset} matchOffset
variable K32
set matchLength 0
set matchOffset 0
if { $index > $K32 } {
set data [string range $data [expr {$index - $K32}] end]
set index $K32
}
set upperBound [expr {1 + [string length $data] - $index}]
if { $upperBound >= $K32 } {
set upperBound $K32
}
set lowerBound 0
while { ($upperBound > 3) && (($upperBound - $lowerBound) > 1) } {
set currentLength [expr {($upperBound + $lowerBound)/2}]
if { $currentLength < 3 } { set currentLength 3 }
set string [string range $data $index \
[expr {$index + $currentLength -1}]]
set currData [string range $data 0 [expr {$index + $currentLength -2}]]
set first 0
set found 0
while { ([set first [string first $string $currData $first]] >= 0) } {
set len [string length $string]
if { ($index - $first) > 255 && $len < 5 } {
if { 5 > $matchLength } {
set string2 [string range $data $index [expr {$index +4}]]
set first2 [string first $string2 $currData $first]
if { $first2 >= 0 } {
set matchOffset [expr {$index - $first2}]
set matchLength 5
set found 1
}
}
} else {
if { $len > $matchLength } {
set matchOffset [expr {$index - $first}]
set matchLength $len
set found 1
}
}
incr first
}
if { $found } {
set lowerBound $currentLength
} else {
set upperBound $currentLength
}
}
if { $matchLength > 0 } {
return 1
} else {
return 0
}
}