MS 2004-09-13
Playing with the algorithm at LZ77 Compression I came with a couple of faster variants. Something is still amiss though with the encode/decode, this code here needs polishing.
With variants in detail only, the encode/decode is taken from LZ77 Compression (as are the tests at the end). The differences are in the way they communicate with maxSubstring.
The two variants for maxSubstring below satisfy:
RHS I found the bug in my lz77 code. See my page for details. It's a pretty simple fix. As a minor note, I found both of our codes to be about equal in speed. The maxSubstring you mention is the fastest timed out at the slowest for me (not by much, though... about 5%), while your slower matcher is pretty much the same time-wise as mine.
MS Thanks. Fixed, with a slight change in fix - it is shorter and faster. Did not dare change it in your page without permission. The "escaped escapes" are here \x01\x01 and \x01\x02 - taking advantage of the fact that we do not encode matches of length < 3.
MS I still measure these as much faster than yours on real files, but still quite slow. I'm not sure why the compressed sizes do not match!
Timing on real files, in seconds
# lz77.tcl - 5482 bytes (your version)
Times: 1.25 0.33 0.11 (100% 26% 8%)
Sizes: 1991 1990 1981
# lz77.test - 18674 bytes (your version)
Times: 7.72 1.45 0.39 (100% 18% 5%)
Sizes: 3901 3891 3896
# ~/.tkchatrc - 106483 bytes (mine; how come it is that large?) Sizes: 30671 30727 30653
# #############################################
# FILE: lz77.tcl - the code for the compression
namespace eval lz77 {
variable lookback 255
variable Escape1 "\x01"
variable Escape2 "\x02"
set K32 [expr {32 * 1024}]
}
proc ::lz77::encode {data} {
variable Escape1
variable Escape2
variable K32
set output ""
set dataLength [string length $data]
append output [string index $data 0]
for {set i 1} {$i < $dataLength} {} {
foreach {length offset} [maxSubstring $i $data] break
if { $length > 0 } {
if { $offset < 255 && $length < 255 } {
set offChar [format %c $offset]
set lenChar [format %c $length]
append output $Escape1$lenChar$offChar
} else {
append output $Escape2
append output [binary format S $length]
append output [binary format S $offset]
}
incr i $length
} else {
set char [string index $data $i]
if { ($char eq $Escape1) || ($char eq $Escape2) } {
append output $Escape1
}
append output $char
incr i
}
}
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 eq $Escape1 } {
set char [string index $data [incr i]]
if { ($char eq $Escape1) || ($char eq $Escape2)} {
append output $char
} else {
scan $char %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
}
}
} elseif { $char eq $Escape2 } {
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
}
} else {
append output $char
}
}
return $output
}The best variant for maxSubstring looks first for the best match of length 3. having found a match of length L, it grows it as much as possible to (L+K), K>=0 - and then looks for a match of length (L+K+1). This is guaranteed to make a single pass through the list, and is the fastest variant to date:
Note that this could include a binary search for the longest match in the inner while-loop for a possible improvement, replacing the linear char-by-char search implemented here.
proc ::lz77::maxSubstring {index data} {
variable K32
set upperBound [expr {[string length $data] - $index}]
if { $upperBound >= $K32} {
set upperBound [expr {$K32 -1}]
}
set lastPossible [expr {$index + $upperBound -1}]
if { $index > $K32 } {
#
# Note that this will be expensive for long strings: the
# data is copied over at each call. Have yet to find a
# better way.
#
set data [string range $data [expr {$index - $K32}] $lastPossible]
set index $K32
set lastPossible [expr {$index + $upperBound-1}]
}
set offset 0
set lastIdx [expr {$index + 2}]
set toMatch [string range $data $index $lastIdx]
while {$lastIdx <= $lastPossible} {
set matchIdx [string last $toMatch $data [expr {$lastIdx - $offset -1}]]
if {$matchIdx < 0} break
# Found a match; find out exactly how long it is
set offset [expr {$index - $matchIdx}]
set next [incr lastIdx]
while {($lastIdx <= $lastPossible) && \
([string index $data $lastIdx] eq \
[string index $data [expr {$lastIdx - $offset}]])} {
incr lastIdx
}
append toMatch [string range $data $next $lastIdx]
}
set len [expr {$lastIdx - $index}]
if {$len < 5} {
if {($len == 2) || ($offset > 255)} {
return {0 0}
}
}
return [list $len $offset]
}Closely related to the algorithm at LZ77 Compression (using a binary search for the maximal length) we have
proc ::lz77::maxSubstring {index data} {
variable K32
set upperBound [expr {[string length $data] - $index}]
if { [string length $data] >= ($index + $K32)} {
set upperBound [expr {$K32 -1}]
}
set lastPossible [expr {$index + $upperBound -1}]
#
# This never returns a match shorter than 5 at arbitrary
# distance. Reduce the data if possible, as it will be searched
# repeatedly.
#
set start 0
if { $index > $K32 } {
set data [string range $data [expr {$index - $K32}] $lastPossible]
set index $K32
}
set matchLength 0 ;# identical to the lowerBound
set matchOffset 1
if {$upperBound > 4} {
set currString [string range $data $index [expr {$index + 4}]]
set start [string last $currString $data [expr {$index +3}]]
if {$start >= 0} {
set matchLength 5 ;# identical to the lowerBound
set matchOffset [expr {$index - $start}]
if {$start} {
set start [string first $currString $data]
if {$start > 0} {
incr index -$start
set data [string range $data $start end]
}
}
} else {
set upperBound 4
}
}
if {$matchLength == 0} {
#
# No match at 5 or more; as this never returns a match shorter than 5
# if it is farther than 255 from the string, we only have to look for
# matches of length 4 or 3 in the last 255 bytes.
#
if {$index > 255} {
set start [expr {$index -255}]
set index 255
set data [string range $data $start [expr {$start + 2}]]
}
}
#
# Now we really start looking
#
while { ($upperBound > 2) && ($upperBound > $matchLength) } {
set currentLength [expr {($upperBound + $matchLength +1)/2}]
if { $currentLength < 3 } { set currentLength 3 }
set currString [string range $data $index [expr {$index + $currentLength -1}]]
# The last possible match has to begin farther away than the
# longest match already found.
set lastIndex [expr {$index - $matchOffset + $currentLength -1}]
if { ([set matchIndex [string last $currString $data $lastIndex]] >= 0) } {
# Note that (matchLength < currentLength) by construction
set matchOffset [expr {$index - $matchIndex}]
set matchLength $currentLength
} else {
set upperBound [expr {$currentLength - 1}]
}
}
return [list $matchLength $matchOffset]
}The tests are taken from LZ77 Compression, adapted to the new maxSubstring interface:
# #############################################
# FILE: lz77.test - tests for lz77
package require tcltest
namespace import tcltest::*
set fName [file join [file dirname [info script]] lz77.tcl]
source $fName
# ========================================
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] } {
binary scan $expect c* exList
binary scan $encoded c* enList
puts "EXPECTED: $exList\nENCODED : $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.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 {
global fName
set f [open $fName]
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 {}
test cycle-1.5 {
cycle a string through encode and decode
} -body {
set f [open [info script]]
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 {
set string {abcdefcdefg}
set index 6
} -body {
::lz77::maxSubstring $index $string
} -result {4 4}
test maxSubstring-1.2 {
Make sure we can get matches of the min length
} -setup {
set string {This is a}
set index 5
} -body {
::lz77::maxSubstring $index $string
} -result {3 3}
test maxSubstring-1.3 {
Return 0 if no match
} -setup {
set string {abcdefghijk}
set index 6
} -body {
lindex [::lz77::maxSubstring $index $string] 0
} -result 0
test maxSubstring-1.4 {
Find the max substring for a string with multiple matches
} -setup {
set string {aaaabbbbaaaaaaaa}
set index 9
} -body {
::lz77::maxSubstring $index $string
} -result {7 1}
test maxSubstring-1.5 {
For a very long string (>32k), remove everything 32k \
past the index
} -setup {
set original "abcdef"
for {set i 0} {$i < 1024} {incr i} {
append original "0123456789012345678901234567890123456789"
}
append original "abcdef"
set index 17
} -body {
::lz77::maxSubstring $index $original
} -result {32767 10}
test maxSubstring-1.6 {
For a very long string (>32k), remove anything more than 32k\
before the index
} -setup {
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 {
::lz77::maxSubstring $index $original
} -result {32767 10}
test maxSubstring-1.7 {
} -setup {
set data "abcdefghij012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123abcdefg"
set index 274
} -body {
::lz77::maxSubstring $index $data
} -result {7 274}