Only black points are stored, so I cheat a little bit ;^)
package require Tk
package require Img
# Decompress filename
proc rle2gif { fichier } {
set fin [open $fichier r]
fconfigure $fin -encoding binary -translation binary
set data [read $fin]
close $fin
catch "image delete gif"
image create photo gif
gif put white -to 0 0 $::largeur $::hauteur
set ln 0
foreach ligne [split $data \x01] {
set col 0
set lres ""
foreach octet [split $ligne {}] {
binary scan $octet b8 res
set pat [string range $res 0 4]
set occ [string range $res 5 7]
append lres [pixel $pat $occ]
}
foreach p [split $lres {}] {
if $p {
gif put black -to $col $ln
}
incr col
}
incr ln
}
gif write [file rootname $fichier]-res.gif
}
# Compress filename
proc gif2rle { fichier } {
catch "image delete rle"
image create photo rle -file $fichier
set data [ascii rle]
set CMP_RES ""
foreach ligne $data {
set PAT ""
set occ 1
while {[string length $ligne]} {
if {[string first 1 $ligne] == -1} {
set ligne ""
}
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] && $occ > 0 && $occ < 8} {
append CMP_RES [octet $PAT $occ]
}
set PAT $pat
set occ 1
}
}
if {[string length $PAT] && $occ > 0 && $occ < 8} {
append CMP_RES [octet $PAT $occ]
}
append CMP_RES \x01
}
set fout [open [file rootname $fichier].rle w]
fconfigure $fout -encoding binary -translation binary
puts -nonewline $fout $CMP_RES
close $fout
}
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 {
return
}
foreach ligne [split $data \n] {
set l ""
if {[string length $ligne] == $::largeur} {
foreach p [split $ligne {}] {
if { $p eq $PN } {
append l 1
} else {
append l 0
}
}
lappend res $l
}
}
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 { pat occ } {
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" default "set N 0"
return [string repeat $pat $N]
}