Gimpで切り出したい画像ファイルを開く。
出力画像のサイズと出力フォルダを起動時に指定する。
北から時計回りに0.jpg、1.jpg、...、7.jpgという名前で、指定したフォルダに保存される。
北の方角を垂直方向のガイドを引いて指定する。
垂直方向のガイドを引かなければ、画像の中心を北と看做す。
垂直方向のガイドが複数引かれていれば、一番左側の垂直方向のガイドの位置を北と看做す。
※グローバル変数を使わないように修正(5/8)
;; パノラマ画像を8枚に分割する
;; 北の方向は、垂直方向ガイドの位置で指定する
;; 垂直方向ガイドがない場合、画像の中心を北と看做す
;; 垂直方向ガイドが複数引かれている場合、一番左側の垂直方向ガイドの位置を北と看做す
;; 指定されたフォルダに画像を保存する
;; メインプロシージャのシステムへの登録
(script-fu-register
;; 登録名
"script-fu-slice-panorama"
;; メニューへの登録位置
"<Image>/Filters/パノラマ画像を切り出し"
;; 説明
"パノラマ画像を8枚に分割して切り出す"
;; 作者
"Atsushi Kokubo"
;; 著作権表示
"kokubo@aomori-u.ac.jp"
;; 制作年月日
"May. 08, 2011"
;; 対象の画像の種類
"*"
SF-IMAGE "入力画像" 0
SF-DRAWABLE "入力ドロワブル" 0
SF-VALUE "出力画像の横幅" "1024"
SF-VALUE "出力画像の高さ" "1024"
SF-DIRNAME "出力先フォルダ" "output-dirname"
)
;; メインプロシージャの定義
(define script-fu-slice-panorama
(lambda (image drawable output-image-width output-image-height output-dirname)
(letrec
(
(debug-mode #f)
(panorama-image-width #f)
(panorama-image-height #f)
(guide-list #f)
(leftmost-guide #f)
(border-list #f)
(border-pair-list #f)
;; デバッグ情報の表示
(debug-print
(lambda (debug-mode s)
(cond
((= debug-mode TRUE) (gimp-message s)))))
;; 画像サイズの変更
(resize-image
(lambda (image panorama-image-width panorama-image-height)
(cond
((not (and (= panorama-image-width (car (gimp-image-width image)))
(= panorama-image-height (car (gimp-image-height image)))))
(gimp-image-scale image panorama-image-width panorama-image-height)
(gimp-displays-flush)))))
;; すべてのガイドを見つける
(get-all-guide
(lambda (image)
(cond
((null? image) #f)
(else
(letrec
(
(guide #f)
(guide-list #f)
;; 与えられたガイドをガイドリストに追加
(add-guide-list
(lambda (image guide-list guide)
(letrec
(
(v-list #f)
(h-list #f)
(orientation #f)
(position #f)
;; ガイドを挿入ソートするための補助関数
(insert
(lambda (n snlat)
(cond
((or (null? snlat) (< n (car snlat))) (cons n snlat))
(else (cons (car snlat) (insert n (cdr snlat)))))))
)
(set! v-list (car guide-list))
(set! h-list (cadr guide-list))
(set! orientation (car (gimp-image-get-guide-orientation image guide)))
(set! position (car (gimp-image-get-guide-position image guide)))
(cond
((= orientation ORIENTATION-VERTICAL)
(set! guide-list (build (insert position v-list) h-list)))
(else
(set! guide-list (build v-list (insert position h-list)))))
guide-list
)))
;; 次のガイドを検出し、ガイドリストに追加する
(main
(lambda (image guide-list guide)
(cond
((= guide 0) guide-list)
(else
(set! guide-list (add-guide-list image guide-list guide))
(main image guide-list (car (gimp-image-find-next-guide image guide)))))))
)
;; ガイドの初期化
(set! guide (car (gimp-image-find-next-guide image 0)))
;; ガイドリストの初期化
(set! guide-list '(() ()))
(main image guide-list guide))))))
;; ガイドリストのプリント
(guide-list-print
(lambda (debug-mode guide-list)
(letrec
(
(v-list #f)
(h-list #f)
(nlat->string
(lambda (nlat)
(cond ((null? nlat) "")
(else (string-append (number->string (car nlat))
" " (nlat->string (cdr nlat)))))))
)
(set! v-list (first guide-list))
(set! h-list (second guide-list))
(debug-print debug-mode (string-append "((" (nlat->string v-list)
") (" (nlat->string h-list) "))")))))
;; 最も左側のガイドを取り出す。垂直のガイドがなければ真ん中
(get-leftmost-guide
(lambda (guide-list panorama-image-width)
(cond
((null? (car guide-list)) (quotient panorama-image-width 2))
(else (caar guide-list)))))
;; ガイドの位置から、境界線のリストを作る
(get-border-list
(lambda (x0 panorama-image-width)
(letrec (
;; n番目のxを求める(x_n = (2*n-1)*panorama-image-width/16)
(nth-x
(lambda (n)
(+ x0 (quotient (* (- (* 2 n) 1) panorama-image-width) 16))))
;; 0から、panorama-image-widthまでの間の値に変換する
(norm
(lambda (x)
(cond
((< x 0) (- (+ x panorama-image-width) 1))
((> x panorama-image-width) (remainder x panorama-image-width))
(else x))))
(main
(lambda (n)
(cond
((= n 8) '())
(else (cons (norm (nth-x n)) (main (+ n 1)))))))
)
(main 0))))
;; 境界線リストのプリント
(print-lat
(lambda (debug-mode lat)
(letrec (
;; アトムのリストを文字列に
(lat->string
(lambda (lat)
(cond
((null? lat) "")
(else (string-append (number->string (car lat))
" " (lat->string (cdr lat)))))))
)
(cond
((null? lat) #f)
(else (debug-print debug-mode (string-append "(" (lat->string lat) ")")))))))
;; 境界線のペアのリストを作る
(get-border-pair-list
(lambda (lat)
(cond
((< (length lat) 2) #f)
(else
(letrec (
(first-border #f)
(main
(lambda (first-border lat)
(cond
((null? (cdr lat))
(cons (build (car lat) (- first-border 1)) '()))
(else
(cons (build (car lat) (cadr lat)) (main first-border (cdr lat)))))))
)
(set! first-border (car lat))
(main first-border lat))))))
;; ペアのリストのプリント
(print-pair-list
(lambda (debug-mode pair-list)
(letrec
(
;; ペアのリストを文字列に変換
(pair-list->string
(lambda (pair-list)
(cond
((null? pair-list) "")
(else (string-append "(" (number->string (caar pair-list))
" " (number->string (cadar pair-list)) ") "
(pair-list->string (cdr pair-list)))))))
)
(cond
((null? pair-list) #f)
(else (debug-print debug-mode (string-append "(" (pair-list->string pair-list) ")")))))))
;; 与えられた境界線ペアのリストからスライスを作って保存
(create-and-save-slices
(lambda (debug-mode image drawable output-dirname border-pair-list)
(letrec
(
;; 与えられた境界線のペアからスライスを作って保存
(create-and-save-slice
(lambda (debug-mode image drawable output-dirname border-pair num)
(letrec
(
(x1 #f)
(x2 #f)
(panorama-image-height #f)
(panorama-image-width #f)
(output-image-width #f)
(tmp-image #f)
(tmp-layer #f)
(tmp-drawable #f)
(filename #f)
(quality #f)
(smoothing #f)
(optimize #f)
(progressive #f)
(comment #f)
(subsmp #f)
(baseline #f)
(restart #f)
(dct #f)
;; 指定したxの範囲をコピーして、指定したxのオフセットにコピー
(copy-paste-region
(lambda (src-image src-drawable dst-drawable src-x-from src-x-to offset-x)
(let* (
(height #f)
(tmp-floating-sel #f)
)
(set! height (car (gimp-image-height src-image)))
;; 選択領域を解除
(gimp-selection-none src-image)
;; 範囲を選択
(gimp-rect-select src-image src-x-from 0 src-x-to height CHANNEL-OP-ADD 0 0)
;; 選択範囲をコピー
(gimp-edit-copy src-drawable)
;; 一時ドロワブルに貼付け
(set! tmp-floating-sel (car (gimp-edit-paste dst-drawable TRUE)))
;; 貼付ける位置を指定
(gimp-layer-set-offsets tmp-floating-sel offset-x 0)
;; フローティング領域を固定
(gimp-floating-sel-anchor tmp-floating-sel)
;; 選択領域を解除
(gimp-selection-none src-image))))
)
;; 変数の初期化
(set! x1 (first border-pair))
(set! x2 (second border-pair))
(set! panorama-image-height (car (gimp-image-height image)))
(set! panorama-image-width (car (gimp-image-width image)))
(set! output-image-width (quotient (car (gimp-image-width image)) 8))
;; JPEG保存のパラメータの指定
(set! filename (string-append output-dirname "/" (number->string num) ".jpg"))
(set! quality 0.85)
(set! smoothing 0.0)
(set! optimize 1)
(set! progressive 1)
(set! comment (string-append output-dirname "/" (number->string num) ".jpg"))
(set! subsmp 0)
(set! baseline 1)
(set! restart 0)
(set! dct 0)
(cond
((and (= (length border-pair) 2) (number? x1) (number? x2))
;; 一時イメージを作成
(set! tmp-image (car (gimp-image-new
output-image-width panorama-image-height RGB)))
(debug-print debug-mode (string-append "tmp-image: " (number->string tmp-image)))
;; 一時レイヤーを作成
(set! tmp-layer (car (gimp-layer-new tmp-image
output-image-width panorama-image-height
RGB-IMAGE "Tmp Layer" 100 NORMAL-MODE)))
(debug-print debug-mode (string-append "tmp-layer: " (number->string tmp-layer)))
;; 一時レイヤーを一時イメージに追加
(gimp-image-add-layer tmp-image tmp-layer -1)
;; 現在のドロワブルを取得
(set! tmp-drawable (car (gimp-image-get-active-drawable tmp-image)))
(debug-print debug-mode (string-append "tmp-drawable: " (number->string tmp-drawable)))
(cond
((< x1 x2)
(copy-paste-region image drawable tmp-drawable
x1 (- x2 x1) 0))
(else
(copy-paste-region image drawable tmp-drawable
x1 panorama-image-width 0)
(copy-paste-region image drawable tmp-drawable
0 x2 (- panorama-image-width x1))
))
;; 表示レイヤーを統合
(gimp-image-flatten tmp-image)
;(gimp-display-new tmp-image)
;; 現在のドロワブルを取得
(set! tmp-drawable (car (gimp-image-get-active-drawable tmp-image)))
;; ファイルに保存
(file-jpeg-save RUN-NONINTERACTIVE tmp-image tmp-drawable
filename filename
quality smoothing optimize progressive
comment subsmp baseline restart dct)
;; 一時イメージを削除
(gimp-image-delete tmp-image)
))
)))
(main
(lambda (border-pair-list num)
(cond
((null? border-pair-list) #t)
(else
(create-and-save-slice debug-mode image drawable
output-dirname (car border-pair-list) num)
(main (cdr border-pair-list) (+ num 1))))))
)
(main border-pair-list 0))))
;; ペアの第一要素
(first
(lambda (p)
(car p)))
;; ペアの第二要素
(second
(lambda (p)
(cadr p)))
;; ペアを作る
(build
(lambda (a1 a2)
(cons a1 (cons a2 (quote ())))))
;; パスからファイル名を取り出す
(path->basename
(lambda (path)
(substring path (+ (last-index-of #\/ path) 1) (string-length path))))
;; パスからディレクトリを取り出す
(path->dirname
(lambda (path)
(substring path 0 (last-index-of #\/ path))))
;; 与えられた文字の文字のリスト中の最後の出現位置
(last-index-of
(lambda (c s)
(letrec
(
(length (string-length s))
(index -1)
(n 0)
(main
(lambda (n)
(cond
((= n length) index)
((char=? c (string-ref s n))
(set! index n)
(main (+ n 1)))
(else (main (+ n 1))))))
)
(main n))))
)
;; 手続き本体
;; デバッグモードの指定
(set! debug-mode FALSE)
;; 出力パノラマ画像のサイズ
(set! panorama-image-width (* 8 output-image-width))
(set! panorama-image-height output-image-height)
(debug-print debug-mode (string-append "output-dirname: " output-dirname))
(debug-print debug-mode (string-append "image: " (number->string image)))
(debug-print debug-mode (string-append "drawable: " (number->string drawable)))
(resize-image image panorama-image-width panorama-image-height)
(set! guide-list (get-all-guide image))
(guide-list-print debug-mode guide-list)
(set! leftmost-guide (get-leftmost-guide guide-list panorama-image-width))
(set! border-list (get-border-list leftmost-guide panorama-image-width))
(print-lat debug-mode border-list)
(set! border-pair-list (get-border-pair-list border-list))
(print-pair-list debug-mode border-pair-list)
(create-and-save-slices debug-mode image drawable output-dirname border-pair-list)
(gimp-displays-flush)
)))
0 件のコメント:
コメントを投稿