When I wrote this, I only focussed on compression speed so sometimes it doesn't compress very well.
How does it work?It uses RLE compression with a fixed 5 pixel pattern ABCDE that can be repeated up to NNN times. Result is sent in a single byte ABCDENNN so NNN can't be greater than 7 (111).
Each line must end with 0x80.
If only white points remain on a line, I don't store them: they're replaced by 0x80.
Finally, if there are more than 70 consecutive points of the same color on a line, I do like that:
- for white points: I add 0x10 0xYY - with YY == number of 5 white point length segments found. So the max number is 0xFF = 255 * 5 = 1275 following white points.
- for black points: like white point but uses 0x20 instead of 0x10.
Some speed results (on a 600 Mhz Crusoe with 192 MB Ram) :
courier12.gif : 892 bytes (done in 0.23 seconds)
times12i.gif : 890 bytes (done in 0.21 seconds)
castle.gif : 15288 bytes (done in 1.85 seconds)
ouster.gif : 2612 bytes (done in 0.30 seconds)
cat.gif : this one fails actually :(
oldeng16.gif : 1976 bytes (done in 0.30 seconds)
The script (updated to work without
TkImg) :
package require Tk
wm withdraw .
# You only need to run this proc to test :
proc Go { giffile } {
set tps [time "gif2rle $giffile"]
rle2gif [file rootname $giffile].rle
set match [photo'eq rle gif]
set tps [expr round([lindex $tps 0] / 10000.0) / 100.0]
set rlesz [file size [file rootname $giffile].rle]
if { $match } {
puts "Done with succes. Results for $giffile :"
puts "Start size : [file size $giffile] bytes"
puts "Compressed size : $rlesz bytes (done in $tps seconds)"
} else {
puts "Error : "
gif write [file rootname $giffile]-rle.gif
puts "$giffile does not match [file rootname $giffile]-rle.gif"
}
}
proc photo'eq {im1 im2} {
set h [image height $im1]
if {[image height $im2] != $h} {return 0}
set w [image width $im1]
if {[image width $im2] != $w} {return 0}
for {set y 0} {$y<$h} {incr y} {
for {set x 0} {$x<$w} {incr x} {
if {[$im1 get $x $y] ne [$im2 get $x $y]} {return 0}
}
}
return 1
}
proc rle2gif { fichier } {
set fin [open $fichier r]
fconfigure $fin -encoding binary -translation binary
set data [read $fin]
close $fin
image create photo gif
gif put white -to 0 0 $::largeur $::hauteur
set ln 0
foreach ligne [split $data \x80] {
set segblanc 0
set segnoir 0
set lg 0
foreach octet [split $ligne {}] {
if { $segblanc } {
incr lg [expr [scan $octet %c] * 5]
set segblanc 0
} elseif { $segnoir } {
set qte [expr [scan $octet %c] * 5]
set ori $lg
incr lg $qte
gif put black -to $ori $ln $lg $ln
set segnoir 0
} elseif {[string match \x10 $octet]} {
set segblanc 1
} elseif {[string match \x20 $octet]} {
set segnoir 1
} else {
foreach p [pixel $octet] {
if {$p} {
gif put black -to $lg $ln
}
incr lg
}
}
}
incr ln
}
}
proc gif2rle { fichier } {
image create photo rle -file $fichier
set data [ascii rle]
set RES ""
foreach ligne $data {
append RES [compress $ligne]
}
set fout [open [file rootname $fichier].rle w]
fconfigure $fout -encoding binary -translation binary
puts -nonewline $fout $RES
close $fout
}
proc compress { ligne } {
if {[string first 1 $ligne] == -1} {
return \x80
} else {
set PAT ""
set occ 1
set RES ""
while {[string length $ligne]} {
if {[string first 1 $ligne] == -1} {
set ligne ""
} elseif {[string first 1 $ligne] > 70} {
if {[string length $PAT]} {
append RES [octet $PAT $occ]
}
set PAT ""
set occ 1
append RES \x10
set ind [expr [string first 1 $ligne]-([string first 1 $ligne]%5)]
if { $ind == 640 } {
set ind 635
} elseif { $ind > 1275 } {
set ind 1275
}
set ligne [string range $ligne $ind end]
eval append RES \\x[format %x [expr int($ind / 5)]]
} elseif {[string first 0 $ligne] > 70} {
if {[string length $PAT]} {
append RES [octet $PAT $occ]
}
set PAT ""
set occ 1
append RES \x20
set ind [expr [string first 0 $ligne]-([string first 0 $ligne]%5)]
if { $ind == 640 } {
set ind 639
} elseif { $ind > 1275 } {
set ind 1275
}
set ligne [string range $ligne $ind end]
eval append RES \\x[format %x [expr int($ind / 5)]]
} else {
set pat [string range $ligne 0 4]
set ligne [string range $ligne 5 end]
if {[string match $pat $PAT] && $occ < 7} {
incr occ
} else {
if {[string length $PAT]} {
append RES [octet $PAT $occ]
}
set PAT $pat
set occ 1
}
}
}
if {[string length $PAT]} {
append RES [octet $PAT $occ]
}
if {[string length $RES]} {
return ${RES}\x80
}
}
}
proc ascii { image } {
set res ""
set ::largeur [image width $image]
if {[expr $::largeur % 5]} {
set fl "[string repeat 0 [expr 5 - ( $::largeur % 5)]] "
} else {
set fl " "
}
set ::hauteur [image height $image]
foreach ligne [$image data] {
foreach p $ligne {
if { "$p" eq "#000000" } {
append res 1
} else {
append res 0
}
}
append res $fl
}
return $res
}
proc octet { pat occ } {
switch $occ \
1 "set N 001" 2 "set N 010" 3 "set N 011" 4 "set N 100" \
5 "set N 101" 6 "set N 110" 7 "set N 111"
return [binary format B8 ${pat}${N}]
}
proc pixel { octet } {
binary scan $octet B8 res
set pat [string range $res 0 4]
set occ [string range $res 5 7]
switch $occ \
001 "set N 1" 010 "set N 2" 011 "set N 3" 100 "set N 4" \
101 "set N 5" 110 "set N 6" 111 "set N 7"
return [split [string repeat $pat $N] {}]
}
