##+##########################################################################
#
# imgSizes.tsh -- command line tool for listing image sizes
# by Keith Vetter, October 28, 2005
#

package require jpeg
package require png
package require tiff

proc GetSize {fname} {
    if {[file size $fname] == 0} {return [list $fname - -]}
    set bestGuess "try[string tolower [file extension $fname]]"

    foreach itype [concat $bestGuess [info procs try.*]] {
        if {[info procs $itype] eq ""} continue

        set try [$itype $fname]
        if {$try ne {}} { return $try }
    }
    return {? - -}
}

proc try.jpg {fname} {
    if {! [::jpeg::isJPEG $fname]} { return {} }
    return [concat jpg [::jpeg::dimensions $fname]]
}
proc try.png {fname} {
    if {! [::png::isPNG $fname]} { return {} }
    array set P [::png::imageInfo $fname]
    return [list png $P(width) $P(height)]
}
proc try.tiff {fname} {
    if {! [::tiff::isTIFF $fname]} { return {} }
    lassign [::tiff::dimensions $fname] w h
    return [list tiff $w $h]
}

proc try.gif {fname} {
    # https://wiki.tcl-lang.org/758
    set data [ReadN $fname 10]
    set sig [string toupper [string range $data 0 5]]
    if {$sig ne "GIF87A" && $sig ne "GIF89A"} { return {} }
    binary scan [string range $data 6 7] s width
    binary scan [string range $data 8 9] s height
    return [list gif $width $height]
}

proc try.ico {fname} {
    # Note, may contain multiple images so we return a list of sizes
    set f [open $fname r]
    fconfigure $f -encoding binary -translation binary

    binary scan [read $f 6] sss zero type numImages
    if {$zero != 0 || ($type != 1 && $type != 2)} { close $f ; return {} }

    set d {}
    for {set i 0} {$i < $numImages} {incr i} {
        set idata [read $f 16]
        binary scan $idata cc w h
        if {$w == 0} {set w 256}
        if {$h == 0} {set h 256}
        append d "${w}x$h "
    }
    close $f
    return [list ico $d ?]
}

proc try.ppm {fname} {
    # see http://netpbm.sourceforge.net/doc/ppm.html
    set data [ReadN $fname 256]
    set magic [string range $data 0 2]
    if {! [regexp {^P6\s$} $magic]} { return {} }

    set n [regexp {^P6\s+(\d+)\s+(\d+)} $data . width height]
    if {! $n} { error "bad ppm format" }
    return [list ppm $width $height]
}
proc try.xbm {fname} {
    # see https://en.wikipedia.org/wiki/X_PixMap#Comparison_with_other_formats
    set data [ReadN $fname 256]
    set n1 [regexp -line {^\s*\#define\s+[a-zA-Z_09]+_width\s+(\d+)} $data . width]
    set n2 [regexp -line {^\s*\#define\s+[a-zA-Z_09]+_height\s+(\d+)} $data . height]
    if {! $n1 || ! $n2} { return {} }
    return [list xbm $width $height]
}
proc try.bmp {fname} {
    # see https://en.wikipedia.org/wiki/BMP_file_format
    set data [ReadN $fname 26]
    if {[string range $data 0 1] ne "BM"} { return {} }
    binary scan [string range $data 18 21] i width
    binary scan [string range $data 22 25] i height
    return [list bmp $width $height]
}

##+##########################################################################
#
# Webp (weppy)
#
# gallery
# =======
# http://news.cnet.com/8301-1023_3-57580664-93/facebook-tries-googles-webp-image-format-users-squawk/
#
# File Format
# ===========
# https://developers.google.com/speed/webp/docs/riff_container
# VP8  :
# VP8L : https://gerrit.chromium.org/gerrit/gitweb?p=webm/libwebp.git;a=blob;f=doc/webp-lossless-bitstream-spec.txt;hb=master
proc try.webp {fname} {
    set data [ReadN $fname 30]
    set chunk0 [string range $data 0 11]
    set chunk1 [string range $data 12 end]

    binary scan $chunk0 "a4ia4" riff size id
    if {$riff ne "RIFF" || $id ne "WEBP"} {return {}}

    binary scan $chunk1 "a4" vp8
    if {$vp8 eq "VP8L"} { return [webp.VP8L $chunk1]}

    # We're assuming start code block starts 11 bytes into the VP8 chunk
    binary scan $chunk1 "a4cu7cu3cu2cu2" vp8 . startCode widthInfo heightInfo
    if {$vp8 ne "VP8 "} { error "unknown VP8 block" }
    lassign $startCode b0 b1 b2
    if {$b0 != 0x9d || $b1 != 0x01 || $b2 != 0x2a} {
        error "missing start code block"
    }
    set horizScale [expr {[lindex $widthInfo 1] >> 6}]
    lset widthInfo 1 [expr {[lindex $widthInfo 1] & 0x3f}]
    set vertScale [expr {[lindex $heightInfo 1] >> 6}]
    lset heightInfo 1 [expr {[lindex $heightInfo 1] & 0x3f}]

    binary scan [binary format cu2cu2 $widthInfo $heightInfo] tt width height
    return [list webp $width $height]
}

proc webp.VP8L {chunk1} {
    binary scan $chunk1 a4icucu4 vp8 size signature sizeInfo
    if {$signature != 0x2f} {
        error "bad VP8L signature byte: $signature"
    }
    lassign $sizeInfo b0 b1 b2 b3
    # 10001111000000010100101100010000
    # 10001111 00000001 01001011 00010000
    # 10001111.000000 01.01001011.0001  0000
    # 10001111.000000  1.01001011.0001

    # 1_webp_ll.webp
    # width: 400px    110001111
    # height: 301px   100101100

    # 2_webp_ll.webp
    # 386x295
    set width [expr {1 + ($b0 << 6) + ($b1 >> 2)}]
    set height [expr {1 + ($b1 << 12) + ($b2 << 4) + ($b3 >> 4)}]
    return [list webp $width $height]
}

proc commify number {regsub -all {\d(?=(\d{3})+($|\.))} $number {\0,}}
proc ReadN {fname n} {
    set fin [open $fname rb]
    set data [read $fin $n]
    close $fin
    return $data
}
################################################################
if {$argv == {}} {
    set argv [list *.gif *.jpg *.jpeg *.png *.ico *.webp *.bmp *.tiff *.tif *.ppm *.xbm]
}
set fnames {}
set longestName 0
foreach arg $argv {
    regsub -all {\\} $arg {/} arg
    foreach fname [glob -nocomplain $arg] {
        if {! [file isfile $fname]} continue
        lappend fnames $fname
        set longestName [expr {max($longestName, 2 + [string length $fname])}]
    }
}

if {$tcl_interactive} return

foreach fname [lsort -dictionary $fnames] {
    set sizes [GetSize $fname]
    lassign $sizes itype w h
    set type "  \[$itype\]"
    if {$itype eq "ico"} {
        puts [format "%-*s%s : %s" $longestName $fname $type $w]
    } else {
        puts [format "%-*s%s : %s x %s" $longestName $fname $type [commify $w] [commify $h]]
    }
}
exit