[Keith Vetter] -- 2015-02-16 Here's a [pure-Tcl%|%tcl only] png decoder. It
can read almost any type of png file including grayscale, indexed and ARGB and
understand all the various types of scanline filtering. The only format it
cannot handle is interlaced images (which is an
http://blog.codinghorror.com/getting-the-most-out-of-png/%|%ill-conceived concept%|% anyway).

The full PNG specification is at http://www.libpng.org/pub/png/spec/1.2.

This package lets you query the color of any pixel or get the full data of
the image.

Exact usage is given in the header comments.


** See also **

   * [pure-tcl BMP reader/writer]
   * [Pure-Tcl GIF LZW encoding]
   * [Pure Tcl JPEG decoder]


** Code **

======
#!/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

======


<<categories>> Graphics | Package