Merge Sorting Images with TCL

I've been having fun shooting film photography this year. Digital scans of film don't have metadata about when each photo was taken, and rolls can get developed and scanned out of order, etc. That makes sorting the photos chronologically difficult to automate.

I wanted a quick way to manually sort a list of images (chronologically or otherwise), and I figured merge sort might be a fun way to do it. It turns out to be rather tedious, especially without an "undo" feature for incorrect input, but it was a fun experiment. A drag and drop GUI tool would be easier.

I decided to do this with Tcl/Tk because it's the most terse GUI framework I've seen, and it was fun practice. The built-in sort command uses merge sort, so I didn't have to write my own. The -command option takes a procedure to compare to items. For my compare procedure I use the vwait command to run the Tk GUI runloop and wait until the variable compare_result is changed via the GUI interface. I was pleased that this works rather well.

I used this script by Keith Vetter as an example for how to manage the image display code and stripped out all the features I didn't want, like toolbar buttons, etc: https://wiki.tcl-lang.org/page/Image+Viewer

image_sort.tcl:

# image_sort.tcl -- merge sort images with user input
# by Remington Furman 2021-01-08
# Based on image_viewer.tcl by Keith Vetter 2013-08-31
#
# Merge sort a list of images based on user input.  Each comparison
# step presents the user with two images, and the image that should
# come first is selected with a key (`a` or `h` for the left image and
# `d` or `l` for the right image).
#
# Write the list of filenames to a file, then call this script like so:
# $ wish image_sort.tcl file_list.txt
#
# Or use Bash process substitution:
# $ wish image_sort.tcl <(ls photos/*.jpg)

package require Tk
package require Img

set S(title) "Image Sorter"
set S(fnamel) ""
set S(fnamer) ""

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 init_display {} {
    global S

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

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

    foreach side {l r} {
        canvas ".c${side}" -bd 5 -highlightthickness 0 \
            -width 600 -height 700 -bg dimgray
        label ".fn${side}" -textvariable "S(fname${side})"
    }

    grid .fnl .fnr
    grid .cl .cr -sticky ns
    grid rowconfigure . 1 -weight 1
    grid columnconfigure . 0 -weight 1
    grid configure .cl -sticky news
    grid configure .cr -sticky news

    foreach canvas {.cl .cr} {
        $canvas create image 0 0 -tag img -anchor nw
        $canvas create rect -100 -100 -100 -100 \
            -tag cropBox -fill {} -outline red -width 3 -dash "-"
    }

    bind all <Control-w> exit
    bind . <Destroy> exit

    foreach event { <Left> <Prior> <leftarrow> a h } {
        bind all $event [list set compare_result -1]
    }

    foreach event { <Right> <Next> <rightarrow> d l } {
        bind all $event [list set compare_result 1]
    }

    bind all <Alt-c> {catch {console show}}
}

proc shrink_image_to_fit_screen {canvas} {
    set w [image width "::img::img$canvas"]
    set h [image height "::img::img$canvas"]
    foreach factor {1 2 3 4} {
        if {$w / $factor < $::S(max,width) && \
            $h / $factor < $::S(max,height)} break
    }
    set ::S("shrunk$canvas") [dict get $::SCALING_FACTORS $factor]
}

proc make_display_image {canvas} {
    global S

    if {"::img::display$canvas" in [image names]} {
        image delete "::img::display$canvas"
    }

    ::image create photo "::img::display$canvas"
    "::img::display$canvas" copy "::img::working$canvas"
    $canvas coords img 0 0
    set S(width,display)  $S(width)
    set S(height,display) $S(height)

    $canvas config -scrollregion [$canvas bbox img]
    $canvas itemconfig img -image "::img::display$canvas"
    $canvas xview moveto 0
    $canvas yview moveto 0
}

proc load_image {fname canvas} {
    global S

    foreach img {"::img::img$canvas" "::img::working$canvas"} {
        if {$img in [image names]} {image delete $img}
    }

    image create photo "::img::img$canvas" -file $fname
    image create photo "::img::working$canvas"
    shrink_image_to_fit_screen $canvas
    resize_image $canvas

    wm geom . {}
    $canvas config -width $S(width,display) -height $S(height,display)
}

proc resize_image {canvas} {
    global S
    set factor [dict get $::SCALING_FACTORS $S("shrunk$canvas")]
    if {"::img::working$canvas" in [image names]} {
        image delete "::img::working$canvas"
    }
    image create photo "::img::working$canvas"
    "::img::working$canvas" copy "::img::img$canvas" -subsample $factor
    set S(width) [image width "::img::working$canvas"]
    set S(height) [image height "::img::working$canvas"]
    set S(size) "${S(width)}x$S(height)"

    make_display_image $canvas
    $canvas config -scrollregion [$canvas bbox img]
    $canvas coords cropBox -100 -100 -100 -100
}

proc compare_images {a b} {
    global compare_result
    global S

    puts -nonewline "Comparing $a and $b: "

    # Display both images.
    load_image $a .cl
    load_image $b .cr
    set S(fnamel) [file tail $a]
    set S(fnamer) [file tail $b]

    # Wait for user input.
    vwait compare_result
    puts $compare_result

    # Return result.
    return $compare_result
}

proc read_file_list {file} {
    set f [open $file r]
    # Split the file by newlines, and remove the empty element from
    # the end of the list.
    set files [lreplace [split [read $f] "\n"] end end]
    close $f
    return $files
}

init_display
set files [read_file_list [lindex $argv 0]]
puts "Sorting:  $files"
set files [lsort -command compare_images $files]
puts "Finished sorting:"
puts $files

exit

This makefile creates images of numbers to test the program with.

Makefile:

# Make test images for image_sort.tcl
#
# The parallelized Make loop trick is inspired by:
# https://stackoverflow.com/a/12110773/182734
#
# The imagemagick command is from:
# https://stackoverflow.com/a/63043486/182734

IMGDIR=img
N := 16
IMAGES := $(addprefix $(IMGDIR)/test_image_, \
          $(addsuffix .png, \
          $(shell seq -w $(N))))

all: $(IMAGES)

$(IMGDIR):
        mkdir $@
$(IMAGES): $(IMGDIR)/test_image_%.png:  | $(IMGDIR)
        convert -gravity center -background black -fill white -size 200x150 \
        caption:"$*" $@