Keith Vetter -- 2015-02-16 Here's a
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
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 edit
#!/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
