Updated 2016-06-17 05:41:13 by kpv ▲

Keith Vetter 2016-06-16 : On a daily basis I use Mac, Linux and Window machines. I like having consistent tools between them all.

This tool is a simple image viewing program. It provides the same interface on all platform to simply display an image, scaled to fit nicely on the screen, and buttons to traverse through all the images in a directory.

##+##########################################################################
#
# ImageViewer.tcl -- simple image viewer
# by Keith Vetter 2013-08-31
#

package require Tk
package require Img
package require tooltip
package require famfamfam::silk

set S(title) "Image Viewer"
set S(info,size) ""
set S(rot) 0
set S(fname) ""
set S(shadow,on) 1

set SCALING_FACTORS [dict create 1 1 2 1/2 3 1/3 4 1/4 1/2 2 1/3 3 1/4 4]

proc DoDisplay {} {
    global FFF S

    wm title . $S(title)
    GetIcons
    destroy {*}[winfo child .]

    set ::S(max,width) [expr {[winfo screenwidth .] - 100}]
    set ::S(max,height) [expr {[winfo screenheight .] - 200}]

    ::ttk::frame .bbar -relief sunken -borderwidth 2
    ::ttk::button .bbar.open -image $FFF(open) -text "Open image" \
        -compound none -style Toolbutton -command OpenImage
    tooltip::tooltip .bbar.open "Open image"
    ::ttk::button .bbar.prev -image $FFF(prev) -text "Previous" \
        -compound none -style Toolbutton -command {NextFile -1}
    tooltip::tooltip .bbar.prev "Previous image"
    ::ttk::button .bbar.next -image $FFF(next) -text "Next" \
        -compound none -style Toolbutton -command NextFile
    tooltip::tooltip .bbar.next "Next image"

    ::ttk::button .bbar.rotleft -image $FFF(ccrot) -text "Rotate left" \
        -compound none -style Toolbutton -command {DoRotate 0}
    tooltip::tooltip .bbar.rotleft "Rotate left"
    ::ttk::button .bbar.rotright -image $FFF(crot) -text "Rotate right" \
        -compound none -style Toolbutton -command {DoRotate 1}
    tooltip::tooltip .bbar.rotright "Rotate right"
    ::ttk::button .bbar.shadow -image $FFF(shadow,$S(shadow,on)) -text "Toggle shadow" \
        -compound none -style Toolbutton -command ToggleShadow
    tooltip::tooltip .bbar.shadow "Toggle shadow"

    tk_optionMenu .bbar.sizes ::S(shrunk) "1" "1/2" "1/3" "1/4"
    .bbar.sizes config -width 4
    for {set i 0} {$i < 4} {incr i} {
        [winfo child .bbar.sizes] entryconfig $i -command ResizeImage
    }
    tooltip::tooltip .bbar.sizes "Resize image"

    pack {*}[winfo child .bbar] -side left

    ::ttk::button .bbar.about -image $FFF(about) -text About \
        -compound none -style Toolbutton -command About
    tooltip::tooltip .bbar.about "About $S(title)"
    pack .bbar.about -side right

    ::ttk::scrollbar .sb_x -command [list .c xview] -orient horizontal
    ::ttk::scrollbar .sb_y -command [list .c yview] -orient vertical
    canvas .c -bd 0 -highlightthickness 0 -width 600 -height 700 -bg white \
        -yscrollcommand [list .sb_y set] \
        -xscrollcommand [list .sb_x set]
    ::ttk::frame .info_bar
    ::ttk::label .info -textvariable ::S(info,size) -background white
    grid .info -in .info_bar -sticky ew
    grid columnconfigure .info_bar {0 1} -weight 1
    grid .bbar - -sticky ew
    grid .c .sb_y -sticky ns
    grid .sb_x -sticky ew
    grid .info_bar - -sticky ew
    grid rowconfigure . 1 -weight 1
    grid columnconfigure . 0 -weight 1
    grid configure .c -sticky news

    .c create image 0 0 -tag img -anchor nw
    .c create rect -100 -100 -100 -100 -tag cropBox -fill {} -outline red -width 3 -dash "-"

    bind Canvas <MouseWheel> [bind Listbox <MouseWheel>]
    bind Canvas <Shift-MouseWheel> [bind Listbox <Shift-MouseWheel>]
    bind Canvas <Mod2-MouseWheel> [bind Listbox <Mod2-MouseWheel>]
    bind Canvas <Shift-Mod2-MouseWheel> [bind Listbox <Shift-Mod2-MouseWheel>]
    # This is conflicting with mouse wheel on my Mac
    #bind .c <2> [bind Text <2>]                        ;# Enable dragging w/ <2>
    #bind .c <B2-Motion> [bind Text <B2-Motion>]

    bind .c <Motion> [list Motion %x %y]  ;# Track mouse even when not pressed

    bind all <Control-w> exit
    bind all <Control-1> ReloadFile
}
proc GetIcons {} {
    global FFF

    set FFF(prev) [::famfamfam::silk get arrow_left]
    set FFF(next) [::famfamfam::silk get arrow_right]
    set FFF(crot)  [::famfamfam::silk get arrow_rotate_clockwise]
    set FFF(ccrot) [::famfamfam::silk get arrow_rotate_anticlockwise]
    set FFF(open) [::famfamfam::silk get book_open]
    set FFF(shadow,0) [::famfamfam::silk get arrow_out]
    set FFF(shadow,1) [::famfamfam::silk get arrow_in]
    set FFF(about) [::famfamfam::silk get comment]
}
proc GetInitImage {} {
    global S argv

    set S(fname) [lindex $argv 0]
    if {[file isfile $S(fname)]} return
    set dirname [expr {$S(fname) eq "" ? "." : [file normalize $S(fname)]}]
    set files [GetAllImagesInDir $dirname]
    set S(fname) [lindex $files 0]
}
proc ShrinkImageToFitScreen {} {
    set w [image width ::img::img]
    set h [image height ::img::img]
    foreach factor {1 2 3 4} {
        if {$w / $factor < $::S(max,width) && $h / $factor < $::S(max,height)} break
    }
    set ::S(shrunk) [dict get $::SCALING_FACTORS $factor]
}
proc MakeDisplayImage {} {
    global S

    if {"::img::display" in [image names]} { image delete ::img::display }
    if {$::S(shadow,on)} {
        ::ShadowBorder::MakeShadowPhoto ::img::working ::img::display
        .c coords img -25 -25
        set S(width,display) [expr {$S(width) + 50}]
        set S(height,display) [expr {$S(height) + 50}]
    } else {
        ::image create photo ::img::display
        ::img::display copy ::img::working
        .c coords img 0 0
        set S(width,display) $S(width)
        set S(height,display) $S(height)
    }
    .c config -scrollregion [.c bbox img]
    .c itemconfig img -image ::img::display
    .c xview moveto 0
    .c yview moveto 0
}
proc LoadNewImage {fname} {
    global S
    set S(fname) $fname

    foreach img {::img::img ::img::working} { if {$img in [image names]} {image delete $img}}
    image create photo ::img::img -file $fname
    image create photo ::img::working
    ShrinkImageToFitScreen
    ResizeImage

    wm geom . {}
    .c config -width $S(width,display) -height $S(height,display)
    wm title . "$S(title) -- [file tail $fname]"
}

proc Background {} {
    if {"::img::bg_single" ni [image names]} {
        image create photo ::img::bg_single -data {
            iVBORw0KGgoAAAANSUhEUgAAABIAAAASCAIAAAGuqymWAAAABGdBTUEAAYagMeiWXwAAAHZJREFU
            KJHVktENwCAIRA/3YyaGYg2G6oetXEmTmkY/en+K7w6IYmYAVLXhkkQEAHeHmUVEy3t3l450Kp+f
            BCDDEkC61gOl1MoI4JgHi6JshNuZ4DiPw164HbXbDDzArryya1ZZxazlx07WY/U/sMpqF6T9AjsA
            YIkx3GnRO1IAAAAASUVORK5CYII=}

        image create photo ::img::bg -width 2000 -height 2000
        .c create image 0 0 -tag bg -anchor nw -image ::img::bg
        .c lower bg
    }
    ::img::bg blank
    ::img::bg copy ::img::bg_single -to 0 0 $::S(width) $::S(height)
}
proc OpenImage {} {
    global S
    set types { {{All Files} *}}
    set types {{"Image files" {*.png *.jpg *.gif *.bmp *.tiff}}
        {"PNG Files" ".png"} {"JPEG Files" ".jpg"} {"GIF Files" ".gif"} {"TIFF Files" "*.tiff"}
        {"All files" *}}
    set fname [tk_getOpenFile -filetypes $types -title "$S(title) Image Load" \
                   -initialdir [file dirname [file normalize $S(fname)]]]
    if {$fname eq ""} return
    LoadNewImage $fname
}
proc comma {num} {
    while {[regsub {^([-+]?\d+)(\d\d\d)} $num "\\1,\\2" num]} {}
    return $num
}
proc Motion {x y} {
    set x [expr {int([.c canvasx $x])}]
    set y [expr {int([.c canvasy $y])}]
    InfoSizeAndMouse $x $y
}
proc InfoSizeAndMouse {{x -999} {y -999}} {
    set ::S(info,size) "$::S(size)"
    if {$x != -999} {
        set ::S(info,size) "$::S(size) \u7c [comma $x],[comma $y]"
    }
}
proc ResizeImage {} {
    global S
    set factor [dict get $::SCALING_FACTORS $S(shrunk)]
    if {"::img::working" in [image names]} { image delete ::img::working }
    image create photo ::img::working
    ::img::working copy ::img::img -subsample $factor
    set S(width) [image width ::img::working]
    set S(height) [image height ::img::working]
    set S(size) "${S(width)}x$S(height)"
    set S(rot) 0

    MakeDisplayImage
    Background
    .c config -scrollregion [.c bbox img]
    .c coords cropBox -100 -100 -100 -100
    InfoSizeAndMouse
}
proc ToggleShadow {} {
    global S
    set S(shadow,on) [expr {! $S(shadow,on)}]
    .bbar.shadow config -image $::FFF(shadow,$S(shadow,on))
    MakeDisplayImage
    Background

    .c config -scrollregion [.c bbox img]
    .c coords cropBox -100 -100 -100 -100
    .c config -background [expr {$S(shadow,on) ? "white" : "gray25"}]
    wm geom . {}
    .c config -width $S(width,display) -height $S(height,display)
}
proc DoRotate {dir} {
    global S
    ImgRot90 ::img::working ::img::working $dir
    set S(width) [image width ::img::working]
    set S(height) [image height ::img::working]

    MakeDisplayImage
    Background

    .c config -scrollregion [.c bbox img]
    .c coords cropBox -100 -100 -100 -100
}
proc ImgRot90 {imgSrc imgDst {clockwise 0}} {
    set w [image width $imgSrc]
    set h [image height $imgSrc]
    set matrix [string repeat "{[string repeat {0 } $h]} " $w]
    if $clockwise {
        set x0 0; set y [expr {$h-1}]; set dx 1; set dy -1
    } else {
        set x0 [expr {$w-1}]; set y 0; set dx -1; set dy 1
    }
    foreach row [$imgSrc data] {
        set x $x0
        foreach pixel $row {
            lset matrix $x $y $pixel
            incr x $dx
        }
        incr y $dy
    }
    $imgDst blank
    $imgDst config -width $h -height $w
    $imgDst put $matrix
}

proc NextFile {{dir 1}} {
    lassign [FindInDir $::S(fname)] n dirname files
    set n [expr {($n+$dir) % [llength $files]}]
    set newImage [file join $dirname [lindex $files $n]]
    set newImage [lindex $files $n]

    LoadNewImage $newImage
    incr n
    wm title . "$::S(title) -- [file tail $newImage] ([comma $n]/[comma [llength $files]])"
}
proc ReloadFile {} {
    NextFile 0
}
proc FindInDir {fname} {
    set fname [file normalize $fname]
    set dirname [file dirname $fname]
    set files [GetAllImagesInDir $dirname]
    set n [lsearch -exact $files $fname]

    return [list $n $dirname $files]
}
proc GetAllImagesInDir {dirname} {
    set files [glob -nocomplain -directory $dirname -type f *.png *.PNG *.gif *.jpg *.jpeg *.JPG \
                   *.bmp *.tiff *.ico *.ppm *.xbm]
    set files [lsort -dictionary $files]
    return $files
}
proc About {} {
    set msg "Image Viewer\nby Keith Vetter June 2016"
    tk_messageBox -title "About Image Viewer" -message $msg -parent .
}

##+##########################################################################
#
# ::ShadowBorder::MakeShadowPhoto -- creates an image with a shadow border
# see http://wiki.tcl.tk/ShadowPhoto
#
namespace eval ::ShadowBorder {}
proc ::ShadowBorder::MakeShadowPhoto {imgSrc imgDst} {
    ::ShadowBorder::_MakeBorderImages
    set w [image width $imgSrc]
    set h [image height $imgSrc]

    set w1 [expr {$w + 25}]
    set w2 [expr {$w + 50}]
    set h1 [expr {$h + 25}]
    set h2 [expr {$h + 50}]

    if {$imgDst in [image names]} { image delete $imgDst }
    image create photo $imgDst -width $w2 -height $h2
    $imgDst copy ::img::border::TL
    $imgDst copy ::img::border::T -to 25 0 $w1 25
    $imgDst copy ::img::border::TR -to $w1 0
    $imgDst copy ::img::border::L -to 0 25 25 $h1
    $imgDst copy ::img::border::R -to $w1 25 $w2 $h1
    $imgDst copy ::img::border::BL -to 0 $h1
    $imgDst copy ::img::border::B -to 25 $h1 $w1 $h2
    $imgDst copy ::img::border::BR -to $w1 $h1
    $imgDst copy $imgSrc -to 25 25
}

##+##########################################################################
#
# ::ShadowBorder::_MakeBorderImages -- makes 8 images which forming the shadow
# gradient for the four sides and four corners.
#
proc ::ShadowBorder::_MakeBorderImages {} {
    if {[info commands ::img::border::T] ne ""} return

    set gradient {\#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#8d8d8d \#999999
        \#a6a6a6 \#b2b2b2 \#bebebe \#c8c8c8 \#d0d0d0 \#dadada \#e2e2e2 \#e8e8e8
        \#eeeeee \#f2f2f2 \#f7f7f7 \#fcfcfc \#fdfdfd \#fdfdfd \#ffffff \#ffffff
        \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff
        \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff \#ffffff}

    image create photo ::img::border::T -width 1 -height 25
    image create photo ::img::border::B -width 1 -height 25
    image create photo ::img::border::L -width 25 -height 1
    image create photo ::img::border::R -width 25 -height 1
    image create photo ::img::border::TR -width 25 -height 25
    image create photo ::img::border::TL -width 25 -height 25
    image create photo ::img::border::BR -width 25 -height 25
    image create photo ::img::border::BL -width 25 -height 25

    for {set x 0} {$x < 25} {incr x} {
        ::img::border::B put [lindex $gradient $x] -to 0 $x
        ::img::border::R put [lindex $gradient $x] -to $x 0

        for {set y 0} {$y < 25} {incr y} {
            set idx [expr {$x<5&& $y<5 ? 0 : round(hypot($x,$y))}]
            ::img::border::BR put [lindex $gradient $idx] -to $x $y
        }
    }
    ::img::border::TL copy ::img::border::BR -subsample -1 -1
    ::img::border::TR copy ::img::border::BR -subsample 1 -1
    ::img::border::BL copy ::img::border::BR -subsample -1 1

    ::img::border::L copy ::img::border::R -subsample -1 1
    ::img::border::T copy ::img::border::B -subsample 1 -1
}

DoDisplay
GetInitImage
LoadNewImage $S(fname)

return

Category Graphics