[Keith Vetter] 2016-06-13 -- Recently I came back from vacation with a bootload of pictures. I wanted to
upload a bunch of them and get prints of them, but I didn't trust the default cropping and the cropping
tool they supply on the website was kind of primitive.

So I wrote this tool that lets you quickly and accurately crop photographs to 4x6, 5x7 or 8x10 ratios.

When you start the tool, it first scales the image so it can fit on your screen. Then you use the
mouse to adjust the crop window. Pressing "m" adds a mask to just see your selection; pressing "f" flips
the orientation and pressing "t" adds grid lines for the "Rule of Thirds". Once you're happy,
press "s" to save the image, then press "n" to move to the next image in the directory and repeat.


======
##+##########################################################################
#
# Photo Crop -- interactively crops photo to 4x6, 5x7 or 8x10 ratio
# 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

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)]"
        }
    }
    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 "New 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 [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
    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
======

<<categories>>Enter Category Here