#!/bin/sh
# Restart with tcl: -*- mode: tcl; tab-width: 8; -*- \
exec tclsh $0 ${1+"$@"}

##+##########################################################################
#
# pngDecode.tsh : decodes and extracts ARGB data about a png.
# by Keith Vetter 2015-02-12
#
# Handles almost all the various png types--grayscale, indexed, RGB,
# etc.--and all the filter types--sub, up, average and Paeth.  all
# color types--grayscale, indexed, RGB, etc. and all scanline filters.
#
# Only type png's it cannot decode are interlaced images.
#
# Usage:
#   set token [PngDecoder create pngFile ?verbosity?]
#      Parses png file and returns a handle
#
#   PngDecoder imageInfo token
#      Returns dictionary of width, height, depth, color, compression, filter
#      and interlace
#
#   PngDecoder get token x y
#      returns alpha, red, green and blue values for pixel at x,y
#
#   PngDecoder data token how
#     Returns the image data for this png as a list of scanlines. The
#     how parameter can be one of:
#       asARGB : alpha, red, green, blue for each pixel (32 bit)
#       asRGB  : red, green, blue for each pixel (32 bit)
#       asIMG  : #RRGGBB for each pixel -- same format as Tk's image data
#
#   PngDecoder makeImage token
#      Returns a Tk image object--requires Tk to be loaded
#
#   PngDecoder cleanup token
#      Frees resources used by token
#
# Example code:
#    set token [PngDecoder create /my/pngfile.png]
#
#    set imageInfo [PngDecoder imageInfo $token]
#    puts "size: [dict get $imageInfo width]x[dict get $imageInfo height]"
#
#    lassign [PngDecoder get $token 10 10] alpha red green blue
#    puts "pixel at 10,10: $alpha/$red/$green/$blue"
#
#    package require Tk
#    set img [PngDecoder makeImage $token]
#    pack [label .l -image $img]
#
#    PngDecoder cleanup $token

namespace eval PngDecoder {
    variable uid 0
    variable verbose 2
    
    namespace ensemble create \
        -subcommands {create imageInfo get data makeImage cleanup}
}
##+##########################################################################
# 
# Returns a PngDecoder handle for decoding this pngFile
# 
proc PngDecoder::create {pngFile {verbosity 0}} {
    variable uid
    variable verbose

    set verbose $verbosity
    set token [namespace current]::[incr uid]

    ParsePngFile $token $pngFile
    DecodeImage $token
    ShowLine 1 ""
    return $token
}
##+##########################################################################
# 
# Returns dictionary with keys width, height, depth, color, compression, filter
# and interlace, and the values are the associated properties of this png.
# 
proc PngDecoder::imageInfo {token} {
    variable $token
    upvar 0 $token state

    return [list width $state(width) \
                height $state(height) \
                depth $state(bit,depth) \
                color $state(color,type) \
                compression $state(compression,method) \
                filter $state(filter,method) \
                interlace $state(interlace)]
}    
##+##########################################################################
# 
# Return the alpha, red, green, blue channels for pixel at x,y
# 
proc PngDecoder::get {token x y} {
    variable $token
    upvar 0 $token state

    if {$x < 0 || $x >= $state(width) || $y < 0 || $y >= $state(height)} {
        error "$x,$y is out of bounds"
    }
    
    set clr [lindex $state(image) $y $x]
    foreach channel {blue green red alpha} {
        set $channel [expr {$clr & 0xFF}]
        set clr [expr {$clr >> 8}]
    }
    return [list $alpha $red $green $blue]
}
##+##########################################################################
# 
# Returns the image data for this png as a list of scanlines. The
# format is one of:
#   asARGB : alpha, red, green, blue for each pixel
#   asRGB  : red, green, blue for each pixel
#   asIMG  : #RRGGBB for each pixel -- same format as Tk's image data
# 
proc PngDecoder::data {token {how asARGB}} {
    variable $token
    upvar 0 $token state

    set types {asARGB asRGB asIMAGE}
    if {$how ni $types} {
        set emsg "usage: PngDecoder data token how"
        append emsg "\n  how is one of [join $types {, }]"
        error $emsg
    }
    
    if {$how eq "asARGB" } {return $state(image) }

    set fmt [expr {$how eq "asIMAGE" ? "#%06x" : "%d"}]
    set scanlines {}
    foreach raw_scanlines $state(image) {
        set scanline {}
        foreach pxl $raw_scanlines {
            set clr [expr {$pxl & 0xFFFFFF}]  ;# Remove alpha
            lappend scanline [format $fmt $clr]
        }
        lappend scanlines $scanline
    }
    return $scanlines
}
##+##########################################################################
# 
# Returns a Tk image from this png. Requires Tk to be loaded.
# 
proc PngDecoder::makeImage {token} {
    if {! [info exists ::tk_version]} {
        error "makeImage requires Tk to be loaded"
    }
    set img [image create photo]
    $img put [data $token asIMAGE]
    return $img
}
##+##########################################################################
# 
# Frees all memory associated with this object.
# 
proc PngDecoder::cleanup {token} {
    variable $token
    upvar 0 $token state
    if {[info exists state]} {
        unset state
    }
}
##+##########################################################################
#############################################################################
# 
# Private routines
#

##+##########################################################################
# 
# Extracts data from all the chunks in the png file
# 
proc PngDecoder::ParsePngFile {token fname} {
    variable $token
    upvar 0 $token state

    ShowLine 1 $fname
    ShowLine 1 "[string repeat = [string length $fname]]"
    ShowLine 1 parsing
    set fh [open $fname r]
    try {
        fconfigure $fh -encoding binary -translation binary -eofchar {}
        if {[read $fh 8] != "\x89PNG\r\n\x1a\n"} {
            ERROR "$fname is not a png file"
            return
        }
        while {[set r [read $fh 8]] != ""} {
            binary scan $r Ia4 len type
            set data [read $fh $len]
            set crc [read $fh 4]

            set handler "Do[string toupper $type]"
            if {[info procs $handler] ne ""} {
                $handler $token $data
            } else {
                ERROR "unknown chunk type: $type"
            }
        }
    } finally {
        close $fh
    }
}
proc PngDecoder::ERROR {msg} {
    puts stderr $msg
}
proc PngDecoder::ShowLine {lvl msg} {
    variable verbose
    if {$lvl > $verbose} return
    puts $msg
}
proc PngDecoder::ShowData {lvl args} {
    variable verbose
    if {$lvl > $verbose} return
    foreach {key value} $args {
        set msg [format "  %-12s %s" "${key}:" $value]
        puts $msg
    }
}
proc PngDecoder::Adorn {value labels} {
    set lbl "-"
    if {$value < [llength $labels]} {
        set lbl [lindex $labels $value]
    }
    if {$lbl eq "-"} { return $value }
    return "$value -- $lbl"
}

##+##########################################################################
# 
# DoXXXX : parses chunk with name XXXX, storing data in state array
# 
proc PngDecoder::DoIHDR {token data} {
    variable $token
    upvar 0 $token state

    set ctypes_ {grayscale - RGB indexed "grayscale with alpha" - RGBA}
    binary scan $data IIccccc state(width) state(height) state(bit,depth) state(color,type) \
        state(compression,method) state(filter,method) state(interlace)

    if {$state(color,type) == 0 || $state(color,type) == 3} {
        set bits [expr {$state(width) * $state(bit,depth)}]
        set state(bytes,row) [expr {int(ceil($bits / 8.0))}]
        set state(bytes,pixel) [expr {$state(bit,depth) > 8 ? 2 : 1}]
    } elseif {$state(color,type) == 2} {
        set state(bytes,row) [expr {$state(width) * 3 * $state(bit,depth) / 8}]
        set state(bytes,pixel) [expr {3 * $state(bit,depth) / 8}]
    } elseif {$state(color,type) == 4} {
        set state(bytes,row) [expr {$state(width) * $state(bit,depth) / 8}]
        set state(bytes,pixel) [expr {2 * $state(bit,depth) / 8}]
    } elseif {$state(color,type) == 6} {
        set state(bytes,row) [expr {$state(width) * 4 * $state(bit,depth) / 8}]
        set state(bytes,pixel) [expr {4 * $state(bit,depth) / 8}]
    }

    ShowLine 2 "IHDR : Image header"
    ShowData 2 size        "$state(width)x$state(height)"
    ShowData 2 "color type"  [Adorn $state(color,type) $ctypes_]
    ShowData 2 depth       $state(bit,depth)
    ShowData 3 compression $state(compression,method)
    ShowData 3 filter      $state(filter,method)
    ShowData 2 interlace   [Adorn $state(interlace) {none Adam7}]
}

proc PngDecoder::DoPLTE {token data} {
    variable $token
    upvar 0 $token state
    
    ShowLine 2 "PLTE : Palette"
    set alpha 0xFF
    set cnt [expr {-1 + [string length $data] / 3}]
    for {set i 0} {$i <= $cnt} {incr i} {
        set rgb [string range $data [expr {$i * 3}] [expr {$i * 3 + 2}]]
        binary scan $rgb cucucu r g b
        set state(palette,$i) [expr {($alpha << 24) | ($r << 16) | ($g << 8) | $b}]
        if {$i < 5} {
            ShowData 3 "palette\[$i]" [format "#%08X" $state(palette,$i)]
        }
    }
    if {$cnt >= 5} {
        ShowLine 3 "  ..."
        ShowData 3 "palette\[$cnt]" [format "#%08X" $state(palette,$cnt)]
    }
}

proc PngDecoder::DoIDAT {token data} {
    variable $token
    upvar 0 $token state

    # Just accumulate info for summary info in IEND
    incr state(idat,cnt)
    append state(idat,data) $data
}

proc PngDecoder::DoIEND {token data} {
    variable $token
    upvar 0 $token state

    # Combine multiple IDAT and display info here
    binary scan $state(idat,data) cucu CMF FLG
    
    set CM [expr {$CMF & 0xF}]
    set methods_ {- - - - - - - - deflate}
    set CINFO [expr {$CMF >> 4}]
    set window [expr {2**($CINFO+8)}]

    set FCHECK [expr {$FLG & 0x1F}]
    set FDICT [expr {($FLG & 0x20) >> 5}]
    set FLEVEL [expr {$FLG >> 6 }]
    set flevels_ {fastest fast default maximum}
    
    ShowLine 2 "IDAT : Image data"
    ShowData 3 segments  $state(idat,cnt) size  [string length $state(idat,data)]
    ShowData 3 method [Adorn $CM $methods_]
    ShowData 3 window $window
    ShowData 3 level "[Adorn $FLEVEL $flevels_] compression"

    ShowLine 2 "IEND : Image trailer"
}

proc PngDecoder::DoTRNS {token data} {
    variable $token
    upvar 0 $token state

    ShowLine 2 "tRNS : Transparency"
    if {$state(color,type) == 3} {  ;# Indexed color png
        set cnt [expr {-1 + [string length $data]}]
        for {set i 0} {$i <= $cnt} {incr i} {
            binary scan [string index $data $i] cu alpha
            set APALETTE($i) $alpha
            set state(palette,$i) [expr {($alpha << 24) | ($state(palette,$i) & 0xFFFFFF)}]
            if {$i > 4} continue
            if {$alpha == 0} {
                set alpha "$alpha -- transparent"
            } elseif {$alpha == 255} {
                set alpha "$alpha -- opaque"
            }
            ShowData 3 "alpha palette\[$i\]" $alpha
        }
        if {$cnt >= 4} {
            set alpha $APALETTE($cnt)
            if {$alpha == 0} {
                set alpha "$alpha -- transparent"
            } elseif {$alpha == 255} {
                set alpha "$alpha -- opaque"
            }
            ShowLine 3 "  ..."
            ShowData 3 "alpha palette\[$cnt\]" $alpha
        }
    } elseif {$state(color,type) == 0} {  ;# Grayscale png
        binary scan $data S alpha
        ShowData 3 "gray alpha" $alpha
        set state(alpha,gray) $alpha
    } elseif {$state(color,type) == 2} {  ;# Truecolor png
        binary scan $data SSS red green blue
        ShowData 3 "red alpha" $red "green alpha" $green "blue alpha" $blue
        set mask [expr {$state(bit,depth) == 8 ? 0xFF : 0xFFFF}]
        set state(alpha,red) [expr {$red & $mask}]
        set state(alpha,green) [expr {$green & $mask}]
        set state(alpha,blue) [expr {$blue & $mask}]
    }
}

proc PngDecoder::DoGAMA {token data} {
    binary scan $data I gamma
    set gamma [expr {$gamma / 100000.}]
    ShowLine 2 "gAMA : Image gamma"
    ShowData 3 gamma $gamma
}

proc PngDecoder::DoCHRM {token data} {
    ShowLine 2 "cHRM : Primary chromaticities"
    set lbls {"white x" "white y" "red x" "red y" "green x" "green y"
        "blue x" "blue y"}
    for {set i 0} {$i < 8} {incr i} {
        set chrm [string range $data [expr {$i*4}] [expr {$i*4 + 3}]]
        binary scan $chrm I val
        ShowData 3 [lindex $lbls $i] $val
    }
}

proc PngDecoder::DoSRGB {token data} {
    binary scan $data c render
    set intents_ {Perceptual "Relative colorimetric"
        Saturation "Absolute colorimetric"}
    ShowData 3 render [Adorn $render $intents_]
}

proc PngDecoder::DoICCP {token data} {
    set name [lindex [split $data \x00] 0]
    ShowLine 2 "iCCP : Embedded ICC profile"
    ShowData 3 name $name
}

proc PngDecoder::DoTEXT {token data} {
    ShowLine 2 "tEXt : Textual data"
    lassign [split $data \x00] key value
    ShowData 3 key $key value $value
}

proc PngDecoder::DoZTXT {token data} {
    ShowLine 2 "zTXt : Compressed textual data"
    lassign [split $data \x00] key
    set keylen [expr {[string length $key] + 1}]
    binary scan [string index $data $keylen] cu method
    set value [string range $data $keylen+1 end]
    set compressed [string range $value 2 end-4]
    set uncompressed [zlib inflate $compressed]
    
    ShowData 3 method [Adorn $method {deflate}] key $key text $uncompressed
}

proc PngDecoder::DoITXT {token data} {
    ShowLine 2 "iTXt : International textual data"
    lassign [split $data \x00] key
    set keylen [expr {[string length $key] + 1}]
    binary scan [string range $data $keylen $keylen+2] cc compress method
    if {$compress == 1} {
        ShowData 3 $key ...
        ShowData 3 compress $compress method [Adorn $method {deflate}] text ...
    } else {
        set rest [string range $data $keylen+2 end]
        lassign [split $rest \x00] language key2 key3 value
        ShowData 3 key $key language $language key3 $key3 text $value
    }
}

proc PngDecoder::DoBKGD {token data} {
    ShowLine 2 "bKGD : Background color"
    set len [string length $data]
    if {$len == 1} {
        binary scan $data cu idx
        ShowData 3 "palette idx"  $idx
    } elseif {$len == 2} {
        binary scan $data cucu gray alpha
        ShowData 3 gray $gray alpha $alpha
    } elseif {$len == 6} {
        binary scan $data SSS red green blue
        ShowData 3 red $red green $green blue $blue
    }
}

proc PngDecoder::DoPHYS {token data} {
    binary scan $data IIc x y units
    ShowLine 2 "pHYs : Physical pixel dimensions"
    ShowData 3 x-axis      $x
    ShowData 3 y-axis      $y
    ShowData 3 units       [Adorn $units {"unknown" "meters"}]
}

proc PngDecoder::DoSBIT {token data} {
    ShowLine 2 "sBIT : Significant bits"
    set len [string length $data]
    if {$len == 1} {
        binary scan $data c gray
        ShowData 3 gray $gray
    } elseif {$len == 2} {
        binary scan $data cc gray alpha
        ShowData 3 gray $gray alpha $alpha
    } elseif {$len == 3} {
        binary scan $data ccc red green blue
        ShowData 3 red $red green $green blue $blue
    } elseif {$len == 4} {
        binary scan $data cccc red green blue alpha
        ShowData 3 red $red green $green blue $blue alpha $alpha
    }
}

proc PngDecoder::DoSPLT {token data} {
    ShowLine 2 "sPLT : Suggested palette"
    set name [lindex [split $data \x00] 0]
    ShowData 3 "palette name" $name
}

proc PngDecoder::DoSPAL {token data} {
    # see ftp://ftp.simplesystems.org/pub/libpng/png-group/documents/history/png-proposed-sPLT-19961107.html
    lassign [split $data \x00] name signature
    ShowLine 2 "spAL : Suggested palette beta sPLT"
    ShowData 3 "palette name" $name signature $signature
}

proc PngDecoder::DoHIST {token data} {
    set cnt [expr {[string length $data] / 2}]
    set min [expr {min(5,$cnt)}]
    ShowLine 2 "hIST : Palette histogram"
    ShowData 3 entries $cnt
    for {set i 0} {$i < $min} {incr i} {
        binary scan [string range $data [expr {2 * $i}] end] S value
        ShowData 3 "hist\[$i]" $value
    }
    if {$min < $cnt} { ShowLine 3 "  ..." }
}

proc PngDecoder::DoTIME {token data} {
    binary scan $data Sccccc year month day hour minute second
    ShowLine 2 "tIME : Image last-modification time"
    ShowData 3 time "$year/$month/$day  $hour:$minute:$second"
}

##+##########################################################################
# 
# Routines to uncompress and decode the raw data
# 

##+##########################################################################
# 
# Runs zlib inflate on the data in the IDAT chunks
#   input:  state(idat,data)
#   output: state(idat,uncompressed)
#
proc PngDecoder::InflateIDAT {token} {
    variable $token
    upvar 0 $token state

    if {[info exists state(idate,uncompressed)]} return
    if {! [info exists state(idat,data)]} { error "no state(idat,data)" }
    
    # See RFC 1950 section 2.2
    # https://www.ietf.org/rfc/rfc1950.txt
    binary scan $state(idat,data) cucu cmf flg
    
    set cm [expr {$cmf & 0xF}]
    set cinfo [expr {$cmf >> 4}]

    set fcheck [expr {$flg & 0x1F}]
    set fdict [expr {($flg & 0x20) >> 5}]
    set flevel [expr {$flg >> 6 }]

    if {$cm != 8} { error "bad compression method $cm" }
    if {$fdict} { error "cannot handle dictionary and compression" }

    set compressed [string range $state(idat,data) 2 end-4]
    set state(idat,uncompressed) [zlib inflate $compressed]
    ShowLine 1 inflating
    ShowData 2 compressed "[string length $compressed] bytes"
    ShowData 2 uncompressed "[string length $state(idat,uncompressed)] bytes"
    return
}
##+##########################################################################
# 
# Decodes the image data stored in the IDAT chunks as a list of scanlines
# with each scanline having a 32-bit ARGB value for each pixel.
#
# The result is kept in $token(image) and accessed via ::PngDecoder::Data
#
# Ths routine is format agnostic but calls format specific functions
# to decode each scanline.
# 
proc PngDecoder::DecodeImage {token} {
    variable $token
    upvar 0 $token state

    if {[info exists state(image)]} return
    if {$state(interlace)} {error "cannot handle interlaced images"}
    set DecodeRowProc "_DecodeRow_$state(color,type)"
    
    InflateIDAT $token
    set state(image) {}
    set last_raw_scanline {}
    ShowLine 2 Scanlines
    set filters {}
    for {set row 0} {$row < $state(height)} {incr row} {
        lassign [GetFilteredScanline $token $row] filter filtered_scanline
        lappend filters $filter
        set raw_scanline [UnfilterScanline $token $filter $filtered_scanline \
                             $last_raw_scanline]
        set img_row [$DecodeRowProc $token $filter $raw_scanline]
        lappend state(image) $img_row
        set last_raw_scanline $raw_scanline
    }
    ShowData 2 filters $filters
}
##+##########################################################################
# 
# Decodes a scanline for color type 0 -- grayscale
# 
proc PngDecoder::_DecodeRow_0 {token filter raw_scanline} {
    variable $token
    upvar 0 $token state

    set img_row {}
    for {set col 0} {$col < $state(width)} {incr col} {
        set gray [GetBits $col $state(bit,depth) $raw_scanline]

        ;# ALPHA : if gray matches tRNS color then alpha=0 else alpha=255
        set alpha 255
        if {[info exists state(alpha,gray)] && $state(alpha,gray) == $gray} {
            set alpha 0
        }
        
        # Scale gray color to 0-255 range
        if {$state(bit,depth) == 1} {
            set gray [expr {($gray << 1) | $gray}]
            set gray [expr {($gray << 2) | $gray}]
            set gray [expr {($gray << 4) | $gray}]
        } elseif {$state(bit,depth) == 2} {
            set gray [expr {($gray << 2) | $gray}]
            set gray [expr {($gray << 4) | $gray}]
        } elseif {$state(bit,depth) == 4} {
            set gray [expr {($gray << 4) | $gray}]
        } elseif {$state(bit,depth) == 16} {
            set gray [expr {($gray >> 8) & 0xFF}]
        }
        
        set clr [expr {($alpha << 24) | ($gray << 16) | ($gray << 8) | $gray}]
        lappend img_row $clr
    }
    return $img_row
}
##+##########################################################################
# 
# Decodes a scanline for color type 2 -- RGB
# 
proc PngDecoder::_DecodeRow_2 {token filter raw_scanline} {
    variable $token
    upvar 0 $token state
    
    set img_row {}
    set alpha 255
    if {$state(bit,depth) == 8} {
        foreach {r g b} $raw_scanline {
            ;# ALPHA : if RGB matches tRNS color then alpha=0 else alpha=255
            if {[info exists state(alpha,red)] && $r == $state(alpha,red) \
                    && $g == $state(alpha,green) && $b == $state(alpha,blue)} {
                set alpha 255
            }
            set clr [expr {($alpha << 24) | ($r << 16) | ($g << 8) | $b}]
            lappend img_row $clr
        }
    } else {
        foreach {r0 r1 g0 g1 b0 b1} $raw_scanline {
            ;# ALPHA : if RRGGBB matches tRNS color then alpha=0 else alpha=255
            if {[info exists state(alpha,red)] \
                    && $state(alpha,red) == ($r0 << 8 | $r1) \
                    && $state(alpha,green) == ($g0 << 8 | $g1) \
                    && $state(alpha,blue) == ($b0 << 8 | $b1)} {
                set alpha 255
            }
            set clr [expr {($alpha << 24) | ($r0 << 16) | ($g0 << 8) | $b0}]
            lappend img_row $clr
        }

    }
    return $img_row
}
##+##########################################################################
# 
# Decodes a scanline for color type 3 -- indexed
# 
proc PngDecoder::_DecodeRow_3 {token filter raw_scanline} {
    variable $token
    upvar 0 $token state
    
    set img_row {}
    for {set col 0} {$col < $state(width)} {incr col} {
        set idx [GetBits $col $state(bit,depth) $raw_scanline]
        ;# ALPHA : alpha = APALATTE(idx) if it exists, 255 otherwise
        ;# Note, we've already updated PALETTE with correct alpha
        lappend img_row $state(palette,$idx)
    }
    return $img_row
}
##+##########################################################################
# 
# Decodes a scanline for color type 4 -- grayscale with alpha
# 
proc PngDecoder::_DecodeRow_4 {token filter raw_scanline} {
    variable $token
    upvar 0 $token state

    set img_row {}
    if {$state(bit,depth) == 8} {
        foreach {gray alpha} $raw_scanline {
            set clr [expr {($alpha << 24) | ($gray << 16) | ($gray << 8) | $gray}]
            lappend img_row $clr
        }
    } else {
        foreach {gray0 gray1 alpha0 alph1} $raw_scanline {
            set clr [expr {($alpha0 << 24) | ($gray0 << 16) | ($gray0 << 8) | $gray0}]
            lappend img_row $clr
        }

    }
    return $img_row
}
##+##########################################################################
# 
# Decodes a scanline for color type 6 - RGBA
# 
proc PngDecoder::_DecodeRow_6 {token filter raw_scanline} {
    variable $token
    upvar 0 $token state

    set img_row {}
    if {$state(bit,depth) == 8} {
        foreach {r g b alpha} $raw_scanline {
            set clr [expr {($alpha << 24) | ($r << 16) | ($g << 8) | $b}]
            lappend img_row $clr
        }
    } else {
        foreach {r0 r1 g0 g1 b0 b1 alpha0 alpha1} $raw_scanline {
            set clr [expr {($alpha0 << 24) | ($r0 << 16) | ($g0 << 8) | $b0}]
            lappend img_row $clr
        }

    }
    return $img_row
}
##+##########################################################################
# 
# Extracts a single scanline from the decompressed image data. Returns list of
# the filter type and the raw bytes.
# 
proc PngDecoder::GetFilteredScanline {token row} {
    variable $token
    upvar 0 $token state

    set idx [expr {1 + $row * (1 + $state(bytes,row))}]
    binary scan [string index $state(idat,uncompressed) $idx-1] cu filter

    set raw_scanline {}
    for {set col 0} {$col < $state(bytes,row)} {incr col} {
        binary scan [string index $state(idat,uncompressed) $idx+$col] cu byte
        lappend raw_scanline $byte
    }

    return [list $filter $raw_scanline]
}
##+##########################################################################
# 
# Returns the raw scanline computed by applying the inverse filter
# algorithm to the filtered-scanline
# 
proc PngDecoder::UnfilterScanline {token filter filtered_scanline last_raw_scanline} {
    variable $token
    upvar 0 $token state

    if {$filter == 0} { return $filtered_scanline }
    
    set raw_scanline {}
    for {set idx 0} {$idx < [llength $filtered_scanline]} {incr idx} {
        set item [lindex $filtered_scanline $idx]
        if {$filter == 1} { ;# Sub filter
            set filter_byte [SmartLindex $raw_scanline $idx-$state(bytes,pixel)]
        } elseif {$filter == 2} { ;# Up filter
            set filter_byte [SmartLindex $last_raw_scanline $idx]
        } elseif {$filter == 3} { ;# Average filter
            set sub [SmartLindex $raw_scanline $idx-$state(bytes,pixel)]
            set prior [SmartLindex $last_raw_scanline $idx]
            set filter_byte [expr {($sub + $prior) / 2}]
        } elseif {$filter == 4} { ;# Paeth filter
            set sub [SmartLindex $raw_scanline $idx-$state(bytes,pixel)]
            set prior [SmartLindex $last_raw_scanline $idx]
            set priorsub  [SmartLindex $last_raw_scanline $idx-$state(bytes,pixel)]
            set filter_byte [PaethPredictor $sub $prior $priorsub]
        } else {
            error "unknown filter type: $filter"
        }
        lappend raw_scanline [expr {($item + $filter_byte) & 0xFF}]
    }
    return $raw_scanline
}
##+##########################################################################
# 
# Safe version of lindex which returns "" for missing items.
# 
proc PngDecoder::SmartLindex {items idx} {
    set value [lindex $items $idx]
    if {$value eq ""} { set value 0 }
    return $value
}
##+##########################################################################
# 
# Computes the PaethPredictor element described in the PNG standard at
# http://www.libpng.org/pub/png/spec/1.2/png-1.2-pdg.html#Filter-type-4-Paeth
# 
proc PngDecoder::PaethPredictor {a b c} {
    set p [expr {$a + $b - $c}]
    set pa [expr {abs($p - $a)}]
    set pb [expr {abs($p - $b)}]
    set pc [expr {abs($p - $c)}]
    if {$pa <= $pb && $pa <= $pc} { return $a }
    if {$pb <= $pc} { return $b }
    return $c
}
##+##########################################################################
# 
# Returns $bbp bits from $data for the $idx item.
# 
proc PngDecoder::GetBits {idx bbp data} {
    # Pixels are always packed into scanlines with no wasted bits
    # between pixels.  Pixels smaller than a byte never cross byte
    # boundaries; they are packed into bytes with the leftmost pixel
    # in the high-order bits of a byte, the rightmost in the low-order
    # bits.
    
    set bit_position [expr {$idx * $bbp}]
    set byte_idx [expr {$bit_position / 8}]
    set bit_in_byte [expr {8 - $bit_position % 8}]

    # Get the byte with the bits we want
    set byte [lindex $data $byte_idx]
    
    if {$bbp == 16} {return [expr {($byte << 8) | [lindex $data $byte_idx+1]}]}

    # Shift desired bits to the right and mask out unwanted bits
    set byte [expr {$byte >> ($bit_in_byte - $bbp)}]
    set mask [expr {2**$bbp - 1}]
    set bits [expr {$byte & $mask}]
    return $bits
}
proc PngDecoder::TestGetBits {} {
    TestGetBits_ 0 4 0xab 0xa
    TestGetBits_ 1 4 0xab 0xb

    TestGetBits_ 0 2 0b11001001 0b11
    TestGetBits_ 1 2 0b11001001 0b00
    TestGetBits_ 2 2 0b11001001 0b10
    TestGetBits_ 3 2 0b11001001 0b01

    TestGetBits_ 0 1 0b10101010 1
    TestGetBits_ 1 1 0b10101010 0
    TestGetBits_ 2 1 0b10101010 1
    TestGetBits_ 3 1 0b10101010 0
    TestGetBits_ 4 1 0b10101010 1
    TestGetBits_ 5 1 0b10101010 0
    TestGetBits_ 6 1 0b10101010 1
    TestGetBits_ 7 1 0b10101010 0
}
proc PngDecoder::TestGetBits_ {idx bbp data expected} {
    set actual [GetBits $idx $bbp $data]
    if {$actual == $expected} return

    puts stderr "bad: GetBits $idx $bbp $data: actual $actual  expected: $expected"
}


##+##########################################################################
# 
# Demo code
# 
if {$argc == 0} {
    ERROR "usage: [file tail $argv0] image.png"
    return
}
set fname [lindex $argv 0]
set token [PngDecoder create $fname]

set imageInfo [PngDecoder imageInfo $token]
puts "size: [dict get $imageInfo width]x[dict get $imageInfo height]"

lassign [PngDecoder get $token 10 10] alpha red green blue
puts "pixel at 10,10: $alpha/$red/$green/$blue"

if {[info exists tk_version]} {
    set img [PngDecoder makeImage $token]
    pack [label .l -image $img]
}

PngDecoder cleanup $token

return


set verbose 0
foreach fname $argv {
    catch { PngDecoder cleanup $token }
    if {$fname eq "-v"} { incr verbose ; continue }
    if {$fname eq "-vv"} { incr verbose 2 ; continue }
    if {$fname eq "-q"} { incr verbose -1 ; continue }
    if {$fname eq "-qq"} { set verbose 0 ; continue }
    set token [PngDecoder create $fname $verbose]
    puts "token: $token"
    if {$extract} {
        set rootname [file rootname $fname]
        set outname "${rootname}_extract[file extension $fname]"
        set img [PngDecoder makeImage $token]
        if {$img ne ""} {
            ShowLine 1 "writing $img to $outname"
            $img write $outname -format png
            image delete $img
        }
    }
}

if {! $tcl_interactive} exit
return