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:
Some speed results (on a 600 Mhz Crusoe with 192 MB Ram) :
package require Tk
package require Img
wm withdraw .
# You only need to run this proc to test :
proc Go { giffile } {
set orisz [file size $giffile]
image create photo tmp -file $giffile
set lg [image width tmp]
if {[expr $lg % 5]} {
set mg [expr 5 - ( $lg % 5)]
image create photo resz
resz put white -to 0 0 $mg [image height tmp]
resz copy tmp -to $mg 0
resz write [file rootname $giffile].xpm -format xpm
set file [file rootname $giffile].xpm
} else {
set file $giffile
}
set tps [time "gif2rle $file"]
rle2gif [file rootname $file].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]
file delete -force [file rootname $giffile].xpm
if { $match } {
puts "Done with succes. Results for $giffile :"
puts "Start size : $orisz bytes"
puts "Compressed size : $rlesz bytes (done in $tps seconds)"
} else {
puts "Error : "
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
set fout [open result.xpm w]
puts $fout "/* XPM */"
puts $fout "static char * .result_xpm[] = \{"
puts $fout "\"$::largeur $::hauteur 2 1\","
puts $fout "\"1\tc #000000\","
puts -nonewline $fout "\"0\tc #FFFFFF\""
foreach ligne [split $data \x80] {
set segblanc 0
set segnoir 0
set res ""
set lg 0
puts $fout ,
puts -nonewline $fout \"
foreach octet [split $ligne {}] {
if { $segblanc } {
set qte [scan $octet %c]
incr lg [expr $qte * 5]
puts -nonewline $fout [string repeat 00000 $qte]
set segblanc 0
} elseif { $segnoir } {
set qte [scan $octet %c]
incr lg [expr $qte * 5]
puts -nonewline $fout [string repeat 11111 $qte]
set segnoir 0
} elseif {[string match \x10 $octet]} {
set segblanc 1
} elseif {[string match \x20 $octet]} {
set segnoir 1
} else {
set res [pixel $octet]
incr lg [string length $res]
puts -nonewline $fout $res
}
}
if { $lg < $::largeur } {
puts -nonewline $fout [string repeat 0 [expr $::largeur - $lg]]
}
puts -nonewline $fout \"
}
puts -nonewline $fout "\};"
close $fout
image create photo gif -file result.xpm
file delete -force result.xpm
}
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]
set ::hauteur [image height $image]
set data [lindex [string map {; "" \" "" , ""} [$image data -format xpm]] end]
set PNindex [lsearch $data #000000]
if {$PNindex} {
set PN [lindex $data [expr $PNindex -2]]
} else {
puts "Erreur : pas de noir !"
return
}
foreach ligne [split $data \n] {
if {[string length $ligne] == $::largeur} {
foreach p [split $ligne {}] {
if { $p eq $PN } {
append res 1
} else {
append res 0
}
}
append res " "
}
}
unset data
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 [string repeat $pat $N]
}