##+##########################################################################
#
# Photo Crop -- interactively crops photo to 4x6, 5x7 or 8x10 ratio
# uses ImageMagick if present which preserves exif data
# by Keith Vetter 2016-06-08

package require Tk
package require Img
package require jpeg

set S(orientations) {Vertical Horizontal}
set S(sizes) {4x6 5x7 8x10}
set S(crop,orientation) "Vertical"
set S(crop,ratio) {4 6}
set S(mask,type) none
set S(need,faux,stipple) [expr {$tcl_platform(os) eq "Darwin"}]
set S(thirds) 0
set S(useImageMagick) [expr {[auto_execok convert] ne ""}]

proc DoDisplay {} {
    global S

    WindowTitle
    wm minsize . 150 150
    . config -bg gray75
    grid [DoControlPane] - -sticky ew

    scrollbar .sby -orient v -command {.c yview}
    scrollbar .sbx -orient h -command {.c xview}
    canvas .c -width 400 -height 600 -bd 0 -highlightthickness 0 -bg gray75 \
        -yscrollcommand {MyScrollFilter .sby set} -xscrollcommand {MyScrollFilter .sbx set}
    grid .c .sby -sticky news
    grid .sbx -sticky ew
    grid rowconfigure . 1 -weight 1
    grid columnconfigure . 0 -weight 1

    .c create image 0 0 -anchor nw -tag image
    .c create rect 0 0 200 300 -tag crop -fill {} -outline red -width 5 -dash "."
    foreach corner {nw ne se sw} {
        .c create rect 0 0 0 0 -fill black -width 0 -tag [list thumb thumb_$corner]
        .c create rect 0 0 0 0 -fill red -width 0 -tag [list thumb2 thumb2_$corner]
    }
    .c create poly -9999 -9999 -9999 -9999 -tag mask -width 0 -fill gray75 -outline gray75
    .c create image 0 0 -anchor nw -tag stipple

    bind Canvas <Button-2>   [bind Text <Button-2>]
    bind Canvas <B2-Motion>  [bind Text <B2-Motion>]
    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>]

    bind .c <Button-1> {ButtonPressHandler down %x %y}
    bind .c <B1-Motion> {ButtonPressHandler move %x %y}

    foreach {key action} {f FlipOrientation z ZoomCropBox m ToggleMask s SaveIt o NewImage t ToggleThirds
        a About n NextImage p {NextImage -1} r {NextImage random} "Key-space" ShowMessage } {
        bind all <$key> $action
    }

    bind .c <Configure> [list ConfigureEventHandler %w %h]
    focus .
}
proc WindowTitle {} {
    set title "Crop [join $::S(crop,ratio) x]"
    if {[info exists ::I(fname)]} {
        append title " -- [file tail $::I(fname)]"
        if {$::I(shrunk) > 1} {
            append title " \[shrunk \uf7$::I(shrunk)]"
        }
        if {[file exists $::I(cropName)]} { append title " <done>" }
    }
    wm title . $title
}
proc MyScrollFilter {args} {
    {*}$args
    lassign [Viewport] left top
    if {$left != 0 || $top != 0} { DefaultCropBox }
    DrawCropBox
}
proc ConfigureEventHandler {w h} {
    if {! [info exists ::I(bbox)]} return
    lassign $::I(bbox) x0 y0 x1 y1
    if {$w > $x1 && $h > $y1} return
    DefaultCropBox
    DrawCropBox
}
proc DoControlPane {} {
    ::ttk::frame .top

    ::ttk::radiobutton .top.mask -text "Mask" -value solid -variable S(mask,type) -command DrawCropBox
    ::ttk::radiobutton .top.stipple -text "Stipple" -value stipple -variable S(mask,type) -command DrawCropBox
    ::ttk::radiobutton .top.none -text "None" -value none -variable S(mask,type) -command DrawCropBox

    tk_optionMenu .top.orient ::S(crop,orientation) {*}$::S(orientations)
    .top.orient config -width [string length "Horizontal"]
    for {set i 0} {$i < [llength $::S(sizes)]} {incr i} {
        [winfo child .top.orient] entryconfig $i -command ChangeOrientation
    }
    tk_optionMenu .top.size ::S(crop,size) {*}$::S(sizes)
    for {set i 0} {$i < [llength $::S(sizes)]} {incr i} {
        [winfo child .top.size] entryconfig $i -command ChangeOrientation
    }

    ::ttk::checkbutton .top.thirds -text "Rule of Thirds" -variable S(thirds) -command DrawCropBox
    ::ttk::button .top.save -text Save -command SaveIt
    ::ttk::button .top.about -text About -command About
    ::ttk::button .top.new -text "Open Image" -command NewImage
    ::ttk::button .top.prev -text "Previous Image" -command {NextImage -1}
    ::ttk::button .top.next -text "Next Image" -command {NextImage 1}

    foreach {a b c d} {
        .top.mask .top.orient .top.new .top.save
        .top.stipple .top.size .top.prev .top.about
        .top.none .top.thirds .top.next x} {
        grid x $a x $b x $c x $d x -sticky ew
    }
    grid columnconfigure .top {0 2 4 6 8} -weight 1
    return .top
}
proc NewImage {} {
    ShowMessage
    set ftypes [list {"Images" {.jpg .png .gif}} {"All Files" *}]
    set fname [tk_getOpenFile -defaultextension ".jpg" -filetypes $ftypes \
                   -initialfile $::I(fname) \
                   -initialdir [file dirname $::I(fname)]]
    if {$fname eq ""} return
    wm geom . {}
    LoadImage $fname
}
proc NextImage {{dir 1}} {
    global I
    ShowMessage
    set idir [file dirname $I(fname)]
    set all {}
    foreach fname [lsort -dictionary [glob -nocomplain -directory $idir -tail *.gif *.jpg *.png]] {
        if {! [string match "*_cropped.*" $fname]} { lappend all $fname }
    }
    if {$all eq {}} return

    if {$dir eq "random"} {
        set idx [expr {int(rand() * [llength $all])}]
    } else {
        set idx [lsearch -exact $all [file tail $I(fname)]]
        if {$idx == -1} {set idx [expr {-$dir}]}
        set idx [expr {($idx + $dir) % [llength $all]}]
    }
    set fname [file join $idir [lindex $all $idx]]
    LoadImage $fname
}
proc LoadImage {fname} {
    global I

    if {"::img::src" in [image names]} { image delete ::img::src }
    if {"::img::display" in [image names]} { image delete ::img::display }
    image create photo ::img::src -file $fname
    image create photo ::img::display
    GetDisplayImage

    set I(fname) $fname
    set I(w) [image width ::img::display]
    set I(h) [image height ::img::display]
    set I(image,format) [expr {[::jpeg::isJPEG $fname] ? "jpeg" : "png"}]
    set I(cropName) "[file rootname $fname]_cropped[file extension $fname]"
    unset -nocomplain I(bbox)
    WindowTitle

    .c itemconfig image -image ::img::display
    set width [expr {min([winfo screenwidth .] - 400, $I(w))}]
    set height [expr {min([winfo screenheight .] - 400, $I(h))}]
    .c config -width $width -height $height
    .c config -scrollregion [list 0 0 $I(w) $I(h)]

    update ;# Need update to insure that [winfo width .] is accurate
    set ::S(crop,orientation) [expr {$I(w) < $I(h) ? "Vertical" : "Horizontal"}]
    ChangeOrientation
}
proc GetDisplayImage {} {
    set w [image width ::img::src]
    set h [image height ::img::src]
    set max_w [expr {[winfo screenwidth .] - 100}]
    set max_h [expr {[winfo screenheight .] - 100}]
    foreach factor {1 2 3 4} {
        if {$w / $factor < $max_w && $h / $factor < $max_h} break
    }
    ::img::display copy ::img::src -subsample $factor $factor
    set ::I(shrunk) $factor
}
proc ButtonPressHandler {action x y} {
    global I

    if {$action eq "down"} {
        set I(mouse,action) {}
        if {[IsInside crop $x $y]} { set I(mouse,action) move }
        foreach corner {nw ne se sw} {
            if {[IsInside thumb_$corner $x $y]} { set I(mouse,action) $corner ; break }
        }
        set I(mouse,x) $x
        set I(mouse,y) $y
        return
    }
    if {$I(mouse,action) eq {}} return
    if {$I(mouse,action) eq "move"} {
        set dx [expr {$x - $I(mouse,x)}]
        set dy [expr {$y - $I(mouse,y)}]
        set I(mouse,x) $x
        set I(mouse,y) $y

        MoveCropBox $dx $dy
        DrawCropBox
        return
    }
    if {$I(mouse,action) in {nw ne se sw}} {
        ResizeCropBox $I(mouse,action) $x $y
        DrawCropBox
        return
    }
    error "bad action: $I(mouse,action)"
}
proc MoveCropBox {dx dy} {
    global I
    lassign [Viewport] left top right bottom
    lassign $I(bbox) x0 y0 x1 y1
    if {$x0 + $dx < $left} { set dx [expr {$left - $x0}] }
    if {$x1 + $dx > $right} { set dx [expr {$right - $x1}] }
    if {$y0 + $dy < $top} { set dy [expr {$top - $y0}] }
    if {$y1 + $dy > $bottom} {set dy [expr {$bottom - $y1}]}

    incr x0 $dx
    incr x1 $dx
    incr y0 $dy
    incr y1 $dy
    set I(bbox) [list $x0 $y0 $x1 $y1]
}
proc ResizeCropBox {corner x y} {
    global I
    lassign [Viewport] left top right bottom
    set x [expr {max($left, min($x, $right))}]
    set y [expr {max($top, min($y, $bottom))}]

    lassign $I(bbox) x0 y0 x1 y1
    if {$corner eq "se"} {
        lassign [NewCropSize $x0 $y0 $x $y] dx dy
        set x1 [expr {$x0 + $dx}]
        set y1 [expr {$y0 + $dy}]
    } elseif {$corner eq "nw"} {
        lassign [NewCropSize $x $y $x1 $y1] dx dy
        set x0 [expr {$x1 - $dx}]
        set y0 [expr {$y1 - $dy}]
    } elseif {$corner eq "ne"} {
        lassign [NewCropSize $x0 $y $x $y1] dx dy
        set x1 [expr {$x0 + $dx}]
        set y0 [expr {$y1 - $dy}]
    } elseif {$corner eq "sw"} {
        lassign [NewCropSize $x $y0 $x1 $y] dx dy
        set x0 [expr {$x1 - $dx}]
        set y1 [expr {$y0 + $dy}]
    } else { error "bad corner: $corner" }

    if {$dx < 25 || $dy < 25} return
    if {$x0 < $left || $x1 > $right || $y0 < $top || $y1 > $bottom} return
    set I(bbox) [list $x0 $y0 $x1 $y1]

    DrawCropBox
}
proc DefaultCropBox {} {
    lassign [Viewport] left top right bottom
    set dx [expr {$right - $left}]
    set dy [expr {$bottom - $top}]
    set newWidth [expr {3*$dx/4}]
    set newHeight [expr {3*$dy/4}]

    set x0 [expr {$left + ($dx - $newWidth) / 2}]
    set y0 [expr {$left + ($dy - $newHeight) / 2}]

    lassign $::S(crop,ratio) width height
    if {$width > $height} {
        set newHeight [expr {round($newWidth * $height / double($width))}]
        if {$newHeight > $dy} {
            set newHeight [expr {$dy - 20}]
            set newWidth [expr {round($newHeight * $width / double($height))}]
        }
    } else {
        set newWidth [expr {round($newHeight * $width / double($height))}]
        if {$newWidth > $dx} {
            set newWidth [expr {$dx - 20}]
            set newHeight [expr {round($newWidth * $height / double($width))}]
        }
    }

    set x1 [expr {$x0 + $newWidth}]
    set y1 [expr {$y0 + $newHeight}]
    set ::I(bbox) [list $x0 $y0 $x1 $y1]
    CenterCropBox
    if {$::S(mask,type) eq "solid"} { set ::S(mask,type) none}
}
proc CenterCropBox {} {
    lassign [Viewport] left top right bottom
    lassign $::I(bbox) x0 y0 x1 y1
    set excess [expr {($right - $left) - ($x1 - $x0)}]
    set dx [expr {($excess/2) - ($x0 - $left)}]
    set excess [expr {($bottom - $top) - ($y1 - $y0)}]
    set dy [expr {($excess/2) - ($y0 - $left)}]

    MoveCropBox $dx $dy
}
proc ZoomCropBox {} {
    global I S
    lassign [Viewport] left top right bottom
    lassign $I(bbox) x0 y0 x1 y1
    lassign $S(crop,ratio) width height

    if {$x1 < $right-1 && $y1 < $bottom-1} {
        set x2 $right
        set y2 [expr {$y1 + ($x2 - $x1) * $height / $width}]
        if {$y2 > $bottom} {
            set y2 $bottom
            set x2 [expr {$x1 + ($y2 - $y1) * $width / $height}]
        }
        ResizeCropBox se $x2 $y2
    } else {
        set x2 $left
        set y2 [expr {$y0 - ($x0 - $x2) * $height / $width}]
        if {$y2 < $top} {
            set y2 $top
            set x2 [expr {$x0 - ($y0 - $y2) * $width / $height}]
        }
        ResizeCropBox nw $x2 $y2
    }
    DrawCropBox
}
proc NewCropSize {x0 y0 x1 y1} {
    set w [expr {$x1 - $x0}]
    set h [expr {$y1 - $y0}]
    lassign $::S(crop,ratio) mul div
    set w2 [expr {round($h * $mul / double($div))}]
    set h2 $h
    return [list $w2 $h2]
}
proc IsInside {tag x y} {
    lassign [Screen2Canvas [list $x $y]] cx cy
    lassign [.c bbox $tag] x0 y0 x1 y1
    if {$cx < $x0 || $cx > $x1 || $cy < $y0 || $cy > $y1} { return false }
    return true
}
proc Screen2Canvas {xy {scaler 1}} {
    set result {}
    foreach {x y} $xy {
        lappend result [expr {$scaler * round([.c canvasx $x])}]
        lappend result [expr {$scaler * round([.c canvasy $y])}]
    }
    return $result
}
proc DrawCropBox {{newWindow 0}} {
    if {! [info exists ::I(bbox)]} return
    ShowMask none
    .c coords crop [Screen2Canvas $::I(bbox)]
    set xy [.c bbox crop]
    foreach corner {nw ne se sw} {
        lassign [ThumbCoords $xy $corner] xy1 xy2
        .c coords thumb_$corner $xy1
        .c coords thumb2_$corner $xy2
    }
    ShowMask
    ShowThirds
}
proc ThumbCoords {xy corner} {
    set ts 11
    set ts2 1

    lassign $xy x0 y0 x1 y1
    if {$corner eq "se"} {
        set xy1 [list [expr {$x1-$ts}] [expr {$y1-$ts}] $x1 $y1]
    } elseif {$corner eq "nw"} {
        set xy1 [list $x0 $y0 [expr {$x0+$ts}] [expr {$y0+$ts}]]
    } elseif {$corner eq "ne"} {
        set xy1 [list [expr {$x1-$ts}] $y0 $x1 [expr {$y0+$ts}]]
    } elseif {$corner eq "sw"} {
        set xy1 [list $x0 [expr {$y1-$ts}] [expr {$x0+$ts}] $y1]
    } else { error "bad corner: $corner" }
    set xy2 {}
    foreach pt $xy1 delta [list $ts2 $ts2 -$ts2 -$ts2] { lappend xy2 [expr {$pt + $delta}] }
    return [list $xy1 $xy2]
}
proc About {} {
    set msg "Photo Crop\nby Keith Vetter June 2016"
    set details "Interactively lets you crop a photo image maintaining proper "
    append details "4x6, 5x7 or 8x10 proportions."
    append details "\n\nIf the image is bigger than the screen, it will be shrunk to "
    append details "fit but cropping will still be done from the full size image."
    append details "\n\nKeyboard shortcuts:\n"
    append details " \u2022 z zoom\n"
    append details " \u2022 f flip orientation\n"
    append details " \u2022 m toggle mask\n"
    append details " \u2022 t toggle rule of thirds grid\n"
    append details " \u2022 s save cropped image\n"
    append details " \u2022 o open image\n"
    append details " \u2022 n next image in directory\n"
    append details " \u2022 p previous image in directory\n"
    append details " \u2022 r random image in directory\n"
    tk_messageBox -title "About Photo Crop" -message $msg -detail $details
}
proc SaveIt {} {
    global I

    if {$::S(useImageMagick)} {
        lassign [Screen2Canvas $I(bbox) $I(shrunk)] x0 y0 x1 y1
        set w [expr {$x1 - $x0}]
        set h [expr {$y1 - $y0}]
        set geom "${w}x${h}+$x0+$y0"
        exec convert -crop $geom -- $I(fname) $I(cropName)
        focus .
    } else {
        image create photo ::img::tmp
        ::img::tmp copy ::img::src -from {*}[Screen2Canvas $I(bbox) $I(shrunk)]
        ::img::tmp write $I(cropName) -format $I(image,format)
        image delete ::img::tmp 
    }
    ShowMessage "Wrote $I(cropName)"
}
proc ShowMessage {{msg ""}} {
    if {[lsearch [image names] ::img::chi] == -1} {
        image create bitmap ::img::chi -data {
            #define chi_width 7
            #define chi_height 7
            static char chi_bits = {
                0x63, 0x77, 0x3e, 0x1c, 0x3e, 0x77, 0x63
            }
        }
    }

    destroy .c.msg
    if {$msg eq ""} return
    label .c.msg -bd 2 -relief ridge -wraplength 350 -text $msg -padx 2m -pady 4m
    label .c.msg.x -image ::img::chi -bd 1 -relief solid
    place .c.msg -relx .5 -rely .3 -anchor c
    place .c.msg.x -relx 1 -rely 0 -x -2 -y 2 -anchor ne
    bind .c.msg.x <1> ShowMessage
    after [expr {5*1000}] ShowMessage
}

proc FlipOrientation {} {
    set ::S(crop,orientation) [expr {$::S(crop,orientation) eq "Vertical" ? "Horizontal" : "Vertical"}]
    ChangeOrientation
}
proc ChangeOrientation {} {
    global S

    set n [scan $S(crop,size) %dx%d a b]
    if {$S(crop,orientation) eq "Vertical"} {
        set newWidth $a
        set newHeight $b
    } else {
        set newWidth $b
        set newHeight $a
    }

    lassign $S(crop,ratio) width height
    set S(crop,ratio) [list $newWidth $newHeight]
    WindowTitle

    DefaultCropBox
    DrawCropBox
}

proc Viewport {} {
    # Returns screen coordinates of image in canvas, needed when image is smaller than canvas
    global I

    set x0 [expr {max(0, round(- [.c canvasx 0]))}]
    set y0 [expr {max(0, round(- [.c canvasy 0]))}]
    set x1 [expr {min([winfo width .c], $x0 + $I(w))}]
    set y1 [expr {min([winfo height .c], $y0 + $I(h))}]
    return [list $x0 $y0 $x1 $y1]
}
proc ToggleMask {} {
    global S
    set d [dict create none solid solid stipple stipple none]
    set S(mask,type) [dict get $d $S(mask,type)]
    DrawCropBox
}
proc ShowMask {{which ""}} {
    global I
    if {$which eq ""} {set which $::S(mask,type)}
    if {$which eq "none"} {
        set xy {-9999 -9999 -9999 -9999}
        .c itemconfig crop -outline red
        .c itemconfig thumb -fill black
        .c itemconfig thumb2 -fill red
        .c coords mask $xy
        .c delete faux_stipple
        .c itemconfig stipple -image {}
    } else {
        if {$which eq "stipple" && $::S(need,faux,stipple)} {
            ShowFauxStipple
            return
        }
        lassign [Screen2Canvas $::I(bbox)] x0 y0 x1 y1
        set xy [list $I(w) $I(h) 0 $I(h) 0 0 $I(w) 0 $I(w) $I(h) \
                    $x1 $y1 $x0 $y1 $x0 $y0 $x1 $y0 $x1 $y1]
        .c coords mask $xy
        .c itemconfig crop -outline {}
        .c itemconfig thumb -fill {}
        .c itemconfig thumb2 -fill {}
        .c itemconfig mask -stipple [expr {$which eq "stipple" ? "gray75" : ""}]
    }
}
proc ShowFauxStipple {} {
    # Fake stippling on Mac's which don't support it natively
    global I
    if {"::img::stipple" ni [image names]} {
        image create photo ::img::blank -width 16 -height 16
        image create photo ::img::stipple -width 16 -height 16
        for {set row 0} {$row < 16} {incr row 4} {
            set row2 [expr {$row + 2}]
            for {set col 0} {$col < 16} {incr col 4} {
                set col2 [expr {$col + 2}]
                ::img::stipple put yellow -to $row $col
                ::img::stipple put yellow -to $row2 $col2
            }
        }
    }
    if {"::img::stippling" ni [image names]} {
        image create photo ::img::stippling -width $I(w) -height $I(h)
    }
    .c itemconfig stipple -image ::img::stippling
    ::img::stippling blank
    ::img::stippling config -width $I(w) -height $I(h)

    # NB. in theory, we don't need to copy ::img::display into ::img::stippling, but
    # without it performance is terrible--over a minute or more.
    ::img::stippling copy ::img::display
    ::img::stippling copy ::img::stipple -to 0 0 $I(w) $I(h)
    ::img::stippling copy ::img::blank -to {*}[Screen2Canvas $I(bbox)] -compositingrule set
}

proc ToggleThirds {} {
    set ::S(thirds) [expr {!$::S(thirds)}]
    DrawCropBox
}
proc ShowThirds {} {
    .c delete thirds
    if {! $::S(thirds)} return
    lassign $::I(bbox) x0 y0 x1 y1
    set dx [expr {$x1 - $x0}]
    set dy [expr {$y1 - $y0}]
    set x1_3 [expr {round($x0 + $dx / 3.0)}]
    set y1_3 [expr {round($y0 + $dy / 3.0)}]
    set x2_3 [expr {round($x0 + 2 * $dx / 3.0)}]
    set y2_3 [expr {round($y0 + 2 * $dy / 3.0)}]
    .c create line $x0 $y1_3 $x1 $y1_3 -tag thirds -dash . -fill red -width 2
    .c create line $x0 $y2_3 $x1 $y2_3 -tag thirds -dash . -fill red -width 2
    .c create line $x1_3 $y0 $x1_3 $y1 -tag thirds -dash . -fill red -width 2
    .c create line $x2_3 $y0 $x2_3 $y1 -tag thirds -dash . -fill red -width 2
}
################################################################
if {[llength $argv] == 0} {
    tk_messageBox -message "Photo Crop\nby Keith Vetter" \
        -detail "Usage: photoCrop <image_file>" -icon warning
    exit
}
if {$argv ne {}} {
    set fname [lindex $argv 0]
}

DoDisplay
LoadImage $fname

return