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, it's spectacularly slow, so it's not worthwhile in its present form. I figured it would be worth posting, however, in case anyone wanted to play with it.
Random Note: The new binary search maxSubstring code takes the encoding of cat.gif from 7.5 hours to 3.5 minutes... yay :)
For a very simple explanation of LZ77 compression... It works iterating from the beginning to the end of the string. For each substring [string range $data $currentIndex end] it checks to see if it has seen that substring (or any shorter version of it with the same starting point) previously. If it hasn't, it outputs the char at $index. If it has, it outputs a code to say how long ago it saw the substring, and how long it is. As an example:
Now, for an interesting twist, the match can include the current substring. For example:
I chose to use the following data/constraints (since I'm not sure how gzip does 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} { #puts -nonewline "\n$i: " set foundAt 0 set foundLen 0 # Get the first 32k bytes of the current string set found [maxSubstring $i $data length offset] if { $found && $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} returnLength upvar ${&matchOffset} returnOffset 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 currString [string range $data $index \ [expr {$index + $currentLength -1}]] set lastIndex [expr {$index + $currentLength -2}] set found 0 if { ([set matchIndex [string last $currString $data $lastIndex]] >= 0) } { set len [string length $currString] if { ($index - $matchIndex) > 255 && $len < 5 } { if { 5 > $matchLength } { set currData [string range $data 0 [expr {$index + $currentLength -2}]] set currString2 [string range $data $index [expr {$index +4}]] set matchIndex2 [string first $currString2 $currData $matchIndex] if { $matchIndex2 >= 0 } { set matchOffset [expr {$index - $matchIndex2}] set matchLength 5 set found 1 } } } else { if { $len > $matchLength } { set matchOffset [expr {$index - $matchIndex}] set matchLength $len set found 1 } } } if { $found } { set lowerBound $currentLength } else { set upperBound $currentLength } } if { $matchLength > 0 } { set returnOffset $matchOffset set returnLength $matchLength return 1 } else { set returnOffset 0 set returnLength 0 return 0 } }
And, the tests...
# ############################################# # FILE: lz77.test - tests for lz77 package require tcltest namespace import tcltest::* source [file join [file dirname [info script]] lz77.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 {} test cycle-1.4 { cycle a string through encode and decode } -body { set f [open [file join [file dirname [info script]] lz77.tcl]] set original [read $f] close $f set encoded [::lz77::encode $original] set changed [::lz77::decode $encoded] if { ![string equal $original $changed] } { #puts "Not Equal:\nORIGINAL: $original\nENCODED : $changed" return "The strings were not equal" } return } -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 { Make sure we can get matches of the min length } -setup { unset -nocomplain length offset set string {This is a} set index 5 } -body { set flag [::lz77::maxSubstring $index $string length offset] list $flag $length $offset } -result {1 3 3} test maxSubstring-1.3 { 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.4 { 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.5 { 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.6 { For a very long string (>32k), remove anything more than 32k\ before the index } -constraints { slow } -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 10} test maxSubstring-1.7 { } -setup { set data "abcdefghij012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123abcdefg" set index 274 } -body { set flag [::lz77::maxSubstring $index $data length offset] list $flag $length $offset } -result {1 7 274}
PS 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...