Outfit Caleidoscope script

caleidoscope.rkt

#lang racket/gui

;;; Files part

(define (image-files-list dir)
  (filter (lambda (p) (let ([ext (bytes->string/utf-8 (path-get-extension p))])
                        (or (string-ci=? ext ".jpg") (string-ci=? ext ".jpeg") (string-ci=? ext ".png"))))
          (directory-list dir #:build? #t)))

(define images-top    (map read-bitmap (image-files-list "top")))
(define images-bottom (map read-bitmap (image-files-list "bottom")))
(define images-coat   (map read-bitmap (image-files-list "coat")))

(define all-combinations (cartesian-product images-bottom images-top images-coat))
(define combinations-count (length all-combinations))

(define (calc-scale src-w src-h dst-w dst-h)
  (min (/ dst-w src-w) (/ dst-h src-h)))

(define (dump-all-combinations)
  (define counter 0)
  (for-each (lambda (comb)
              (let* ([bmp-top  (first comb)]
                     [bmp-bot  (second comb)]
                     [bmp-coat (third comb)]
                     [res-w    1000]
                     [res-h    4500]
                     [bmp-res  (make-bitmap res-w res-h)]
                     [bmp-tmp  (make-bitmap res-w (/ res-h 3))]
                     [dc       (new bitmap-dc% [bitmap bmp-res])]
                     [dc1      (new bitmap-dc% [bitmap bmp-tmp])]
                     [draw-bmp (lambda (bmp offset)
                                 (let* ([w     (send bmp get-width)]
                                        [h     (send bmp get-height)]
                                        [scale (calc-scale w h res-w (/ res-h 3))])
                                   (send dc1 set-scale scale scale)
                                   (send dc1 draw-bitmap bmp 0 0)
                                   (send dc draw-bitmap bmp-tmp 0 offset)
                                   (send dc1 clear)))])
                (draw-bmp bmp-top 0)
                (draw-bmp bmp-bot (/ res-h 3))
                (draw-bmp bmp-coat (/ (* res-h 2) 3))
                (send bmp-res save-file (build-path "combinations" (string-append "comb" (number->string counter) ".jpg")) 'jpeg)
                (set! counter (+ counter 1))))
            all-combinations))

;;; Main window section

(define main-window (new frame% [label "Outfit Caleidoscope"] [width 800] [height 600]))

; Make a static text message in the frame
(define msg (new message% [parent main-window]
                 [label  "0"]))

; Close button
(new button% [parent main-window]
     [label "Close"]
     ; Callback procedure for a button click:
     [callback (lambda (button event)
                 (send main-window show #f))])

(define (show-done-msgbox)
  (let ([d (new dialog% [parent main-window] [label "All done."] [width 300] [height 100])])
    (new message% [parent d] [label "All combinations are written to disk."])
    (new button% [parent d] [label "Ok"]
         [callback (lambda (button event)
                     (send d show #f))])
    (send d show #t)))

(new button% [parent main-window]
     [label "Dump all"]
     ; Callback procedure for a button click:
     [callback (lambda (button event)
                   (dump-all-combinations)
                   (show-done-msgbox))])


;;; Horizontal panel section

(define current-combination 0)

(define h-panel (new horizontal-panel% [parent main-window]))
(new button% [parent h-panel]
     [label "Left"]
     [callback (lambda (button event)
                 (set! current-combination (max 0 (- current-combination 1)))
                 (send msg set-label (number->string current-combination))
                 (send canvas-panel refresh-canvas-panel))])


;;; Vertical panel with canvases for images

(define canvas-panel%
  (class vertical-panel%
    (super-new)
    (define canvas-top (new canvas% [parent this]
                            [paint-callback
                             (lambda (canvas dc)
                               (let ([bmp-top (first (list-ref all-combinations current-combination))])
                                 (send dc draw-bitmap bmp-top 0 0)))]))
    
    (define canvas-bottom (new canvas% [parent this]
                               [paint-callback
                                (lambda (canvas dc)
                                  (let ([bmp-bottom (second (list-ref all-combinations current-combination))])
                                    (send dc draw-bitmap bmp-bottom 0 0)))]))
    
    (define canvas-shoes (new canvas% [parent this]
                              [paint-callback
                               (lambda (canvas dc)
                                 (let ([bmp-coat (third (list-ref all-combinations current-combination))])
                                   (send dc draw-bitmap bmp-coat 0 0)))]))
    
    (define/public (refresh-canvas-panel)
      (send canvas-top    refresh-now)
      (send canvas-bottom refresh-now)
      (send canvas-shoes  refresh-now))))

(define canvas-panel (new canvas-panel% [parent h-panel]))

;;; End canvas-panel

;; "Right" button to h-panel
(new button% [parent h-panel]
     [label "Right"]
     [callback (lambda (button event)
                 (set! current-combination (min combinations-count (+ current-combination 1)))
                 (send msg set-label (number->string current-combination))
                 (send canvas-panel refresh-canvas-panel))])

;;; End h-panel

;;; Show the main window
(send main-window show #t)