'''[PS] 3Sept2004'''

My entry:

----

 #!/bin/sh
 # -*- tcl -*-
 # The next line is executed by /bin/sh, but not tcl \
 exec wish "$0" ${1+"$@"}

 package require Tk
 package require Img
 proc ps_compress_bitstream { bits } {
    
    # Stream encoding:
    # bit-1bitrepeatcount
    # samebit-1bit longer count word
    
    # Turn into bit length bit length ... list:
    set prevbit ""
    set cnt 0
    set repeat_list {}
    foreach bit [split $bits ""] {
        if {$cnt > 0 && $bit ne $prevbit} {
            lappend repeat_list $prevbit $cnt
            set cnt 0
        }
        set prevbit $bit
        incr cnt        
    }
    lappend repeat_list $prevbit $cnt
    
    foreach {bit len} $repeat_list {
        #Do the actual encoding:
        set bin [int_to_bin $len]
        set i 0
        set bits [string range $bin 0 $i]
        set bin [string range $bin [expr {$i+1}] end]
        while { $bits ne "" } {
            set bits $bits[string repeat 0 [expr {$i+1-[string length $bits]}]]
            append out $bit $bits
            incr i
            set bits [string range $bin 0 $i]
            set bin [string range $bin [expr {$i+1}] end]
        }
    }
    return $out
 }
 
 proc ps_decompress_bitstream { compressed } {
    set lastbit ""
    set count ""
    set num 0
    for {set i 0} {$i < [string length $compressed] } {incr i} {
        set bit [string index $compressed $i]
        if { $i>0 && $bit ne $lastbit } {
            append out [string repeat $lastbit [bin_to_int $count]]
            set count ""
            set num 1
        } else {
            incr num
        }
        append count [string range $compressed [expr {$i+1}] [expr {$i+$num}]]
        set i [expr {$i+$num}]
        set lastbit $bit
    }
    append out [string repeat $lastbit [bin_to_int $count]]
 }

 proc photo'eq {im1 im2} {
    #-- returns 1 if both images are exactly equal, else 0
    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 photo'colors img {
    #-- return a list of {{r g b} n} tallies of pixel colors,
    #-- sorted decreasing by n (number of pixels of that color)
    set h [image height $img]
    set w [image width  $img]
    for {set y 0} {$y<$h} {incr y} {
        for {set x 0} {$x<$w} {incr x} {
            set color [$img get $x $y]
            if {![info exists a($color)]} {set a($color) 0}
            incr a($color)
        }
    }
    foreach {color n} [array get a] {lappend tally [list $color $n]}
    lsort -decreasing -index 1 -integer $tally
 }
 proc binimg'encode img {
     set clrs [photo'colors $img]
     if {[llength $clrs] != 2} { return -code error "not a 2 color image" }
     set clr0 [lindex $clrs 0 0]
     set clr1 [lindex $clrs 1 0]
     set h [image height $img]
     set w [image width  $img]
     set str ""
     for {set y 0} {$y<$h} {incr y} {
         for {set x 0} {$x<$w} {incr x} {
             set color [$img get $x $y]
             append str [string equal $color $clr1]
         }
     }
     foreach {r g b} $clr0 { set color0 [expr {$r<<16 | $g <<8 | $b}]; break }
     foreach {r g b} $clr1 { set color1 [expr {$r<<16 | $g <<8 | $b}]; break }
     # store image as <w><h><clr0><clr1><binimgdata> where w and h are shorts
     set binstr [binary format ssiib* $w $h $color0 $color1 $str]
     return $binstr
 }
 proc binimg'decode data {
     binary scan $data ssiib* w h color0 color1 clrs
     set img [image create photo -width $w -height $h]
     set clr(0) \#[format %.6x $color0]
     set clr(1) \#[format %.6x $color1]
     set i 0
     set data ""
     set line ""
     foreach c [split $clrs {}] {
         lappend line $clr($c)
         if {[incr i] eq $w} {
             set i 0
             lappend data $line
             set line ""
         }
     }
     $img put $data -to 0 0
     return $img
 }
 
 proc int_to_bin { val } {
    binary scan [binary format i $val] b* bits
    return [string trimright $bits 0]    
 }
 
 proc bin_to_int { bits } {
    set bits $bits[string repeat 0 [expr {32-[string length $bits]}]]    
    binary scan [binary format b* $bits] i val
    return $val
 }
 
 
 proc ps_compress { file outfile } {
    set img [image create photo -file $file]        
    binary scan [binimg'encode $img] b* bin_stream    
    image delete $img
    set out [open $outfile w]
    fconfigure $out -translation binary
    set compressed [ps_compress_bitstream $bin_stream]
    puts -nonewline $out [binary format b* $compressed]
    close $out        
 }
 
 proc ps_decompress { file outfile } {
    set in [open $file r]
    fconfigure $in -translation binary
    binary scan [read $in] b* compressed    
    close $in
    set binimg [ps_decompress_bitstream $compressed]
    set img [binimg'decode [binary format b* $binimg]]
    $img write $outfile
    image delete $img    
 }
 
 ps_compress p:/times12i.gif p:/times12i.gif.psz
 ps_decompress p:/times12i.gif.psz p:/times12i-res.gif

 ps_compress p:/courier12.gif p:/courier12.gif.psz
 ps_decompress p:/courier12.gif.psz p:/courier12-res.gif