縮小歪み率：図像の模写を行う際の定量的評価アプローチ

ratio.rkt

#lang racket/base

(require racket/format)
(require racket/list)
(require racket/vector)

;
; command line helpers
;

(define help-message
"ratio: CLIP STUDIO用比率簡約化ツール
    usage 1: ratio rate <width1> <length1> <width2> <length2>
        <width1>, <length1>, <width2>, <length2>には小数を入力します。
        幅、長さが<width2>, <length2>の長方形が、
        幅、長さが<width1>, <length1>の長方形に対して
        どの程度歪んでいるかを算出します。
    usage 2: ratio search <width> <length>
        <width>, <length>には小数を入力します。
        0.1〜10.0の範囲に近似された長方形の幅と長さを算出します。")

(define (displayln-error str)
    (displayln str (current-error-port))
    (exit))

(define args (current-command-line-arguments))

(define (args= n) (= (vector-length args) n))

;
; parser for floating point numbers
;

(define (read-from-string s)
    (define p (open-input-string s))
    (define res (read p))
    (close-input-port p)
    res)

(define (floating-point-format? s)
    (cond ((string=? s ".") #f)
          ((string=? s "") #f)
          (else (regexp-match? #rx"^[0-9]*(|\\.)[0-9]*$" s))))

(define (string->exact s)
    (define (err)
        (fprintf (current-error-port)
                 "ERROR: ~sは小数ではありません~n"
                 s)
        (exit))
    (unless (floating-point-format? s) (err))
    (define res (read-from-string (string-append "#e" s)))
    (unless (exact? res) (err))
    res)

;
; distortion rate
;

(define (get-shrink-distortion-rate a b c d)
    (define ad (* a d))
    (define bc (* b c))
    (define det (- ad bc))
    (cond
        ((= det 0) 0)
        ((> det 0) (/ det ad))
        (else (- (/ det bc)))))

;
; search algorithm
;

(define step #e0.1)

(define (get-smaller-c a b d)
    (* (floor (/ (/ (* a d) b) step)) step))

(define (get-greater-c a b d)
    (* (ceiling (/ (/ (* a d) b) step)) step))

(define (in-range? x)
    (and (> x 0) (<= x 10)))

(define (exact-zero? x)
    (and (exact? x) (zero? x)))

(define large-number 10000)

(define (search-c-and-d a b)
    (define (smaller min-rate min-c min-d lst greater)
        (define d (first lst))
        (define c (get-smaller-c a b d))
        (define rate (get-shrink-distortion-rate a b c d))
        (define swapping (and (in-range? c) (< (abs rate) (abs min-rate))))
        (if (exact-zero? rate)
            (list c d)
            (greater (if swapping rate min-rate)
                     (if swapping c min-c)
                     (if swapping d min-d)
                     lst)))
    (define (greater min-rate min-c min-d lst)
        (define d (first lst))
        (define c (get-greater-c a b d))
        (define rate (get-shrink-distortion-rate a b c d))
        (define swapping (and (in-range? c) (< (abs rate) (abs min-rate))))
        (cond ((exact-zero? rate) (list c d))
              ((null? (rest lst))
               (list (if swapping c min-c)
                     (if swapping d min-d)))
              (else (smaller (if swapping rate min-rate)
                             (if swapping c min-c)
                             (if swapping d min-d)
                             (rest lst)
                             greater))))
    (smaller large-number
             large-number
             large-number
             (range #e0.1 #e10.1 #e0.1)
             greater))

;
; main code
;

(define (when-rate)
    (unless (args= 5) (displayln-error "引数の数が不正です"))
    (define a (string->exact (vector-ref args 1)))
    (define b (string->exact (vector-ref args 2)))
    (define c (string->exact (vector-ref args 3)))
    (define d (string->exact (vector-ref args 4)))
    (define rate (get-shrink-distortion-rate a b c d))
    (printf "縮小歪み率: ~a ( ~a % ) [ ~a ]~n"
            (~r rate #:precision 5)
            (~r (* rate 100) #:precision 1)
            rate))

(define (when-search)
    (unless (args= 3) (displayln-error "引数の数が不正です"))
    (define a (string->exact (vector-ref args 1)))
    (define b (string->exact (vector-ref args 2)))
    (define res (search-c-and-d a b))
    (define c (first res))
    (define d (second res))
    (when (= c large-number) (displayln-error "解を見つけることができませんでした"))
    (printf "近似長方形の幅: ~a, 長さ: ~a~n"
            (~r c #:precision 1)
            (~r d #:precision 1))
    (define rate (get-shrink-distortion-rate a b c d))
    (printf "縮小歪み率: ~a ( ~a % ) [ ~a ]~n"
            (~r rate #:precision 5)
            (~r (* rate 100) #:precision 1)
            rate))

(when (vector-empty? args) (displayln-error help-message))

(define arg0 (vector-ref args 0))

(cond ((string=? arg0 "rate") (when-rate))
      ((string=? arg0 "search") (when-search))
      (else (displayln-error help-message)))

(exit)