##+##########################################################################
#
# 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

    bind all <Left> [list NextFile -1]
    bind all <Prior> [list NextFile -1]
    bind all <leftarrow> [list NextFile -1]

    bind all <Right> [list NextFile]
    bind all <Next> [list NextFile]
    bind all <rightarrow> [list NextFile]

    bind all <Home> [list NextFile first]
    bind all <End> [list NextFile last]

    bind all <Alt-c> {catch {console show}}
}
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

    switch $dir {
        "first" {
            set n 0
        }
        "last" {
            set n [expr [llength $files]-1]
        }
        default {
            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 https://wiki.tcl-lang.org/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