Tool for showing images

rapid-image-viewer.rkt

#lang racket

;; 
;; Displays a directory full of images in rapid succession.
;; Handy for checking annotations or finding irregularities
;; in large-scale datasets.
;;
;; Usage:
;;   - racket rapid-image-viewer.rkt [imglist]
;;     Will show all of the '*.jpg' files given as lines in `imglist`,
;;     or in the current directory if `imglist` is not specified
;;
;; Controls:
;;   - Left, right: Seek back and forth one image
;;   - Space: Start/stop showing images in 10 FPS
;;   - Enter: Output current image to stdout

(require racket/gui
         slideshow/pict)

(define images
  (if (> (vector-length (current-command-line-arguments)) 0)
      ;(vector->list (current-command-line-arguments))
      (apply append (map file->lines (vector->list (current-command-line-arguments))))
      (sort
       (for/list ([image-file (in-directory (current-directory))]
                  #:when (regexp-match? #rx".jpg" image-file))
         image-file)
       string<=?
       #:key path->string)))

(define which-img 0)
(define current-pic (blank 5 5))

(define (refresh-img)
  (set! current-pic (bitmap (make-object bitmap% (list-ref images which-img)))))
(refresh-img)


(define (advance)
  (when (< which-img (sub1 (length images)))
      (set! which-img (add1 which-img))
      (refresh-img)))
(define (go-back)
  (when (> which-img 0)
      (set! which-img (sub1 which-img))
      (refresh-img)))

(let* ([frame (new frame% [label "Squirrel Dataset Viewer"])]
       [gauge (new gauge% [label #f] [range (length images)] [parent frame])]
       [refresh-gauge (λ()
                        (send gauge set-value which-img)
                        (send frame set-label
                              (format "~a   (~V/~v)"
                                      (path->string
                                       (file-name-from-path (list-ref images which-img)))
                                      which-img
                                      (length images))))]
       [canvas (new (class canvas%
                      (super-new [parent frame]
                                 [min-width 300]
                                 [min-height 300]
                                 [paint-callback
                                  (λ (canvas dc)
                                     (send dc set-smoothing 'smoothed)
                                     (draw-pict (scale current-pic
                                                       (min
                                                        (/ (send this get-height)
                                                           (pict-height current-pic))
                                                        (/ (send this get-width)
                                                           (pict-width current-pic))))
                                                dc
                                                0 0))])
                      (send this set-canvas-background (make-object color% "black"))
                      (define timer (new timer% [notify-callback
                                                 (λ()
                                                   (advance)
                                                   (refresh-gauge)
                                                   (send this refresh))]))
                      (define running #f)
                      (define (stop-timer)
                        (send timer stop)
                        (set! running #f))
                      (define (start-timer)
                        (send timer start 100)
                        (set! running #t))
                      (define (toggle-timer)
                        (cond [(not running)
                               (start-timer)]
                              [else
                               (stop-timer)]))

                      (define/override (on-char ch)
                        (case (send ch get-key-code)
                          [(#\space)
                           (toggle-timer)]
                          [(right)
                           (advance)
                           (stop-timer)
                           (refresh-gauge)
                           (send this refresh)]
                          [(left)
                           (go-back)
                           (stop-timer)
                           (refresh-gauge)
                           (send this refresh)]
                          [(#\return)
                           (displayln (path->string (list-ref images which-img)))
                           (flush-output)]))))])

  (send frame show #t))