とあるGIMPのロゴ生成<スクリプト>

すいうさんに教えてもらった、「とある画像の自動生成」がおもしろかったので、
GIMPにも是非！とばかりに作ってみちゃいました。
まだまだ作り途中なので、カタカナが無かったり、グラデーションがかかって無かったりしますが、今の状態でも結構遊べます。

下のスクリプトをScript-fuのフォルダにコピペしてからGIMPを起動させると、「ファイル→画像の生成→ロゴ」の下に変なのが出てきます
フォント名の初期値がLinuxのフォント名に決め打ちになっちゃってますけど、Windowsでも、MS明朝あたりに変更すれば、割とまともに動くと思います。

---

;;; toaru.scm -*-scheme-*-
;;; Author: Sigetch
;;; Version 0.2

;;; Code:
(define (script-fu-toaru-logo
	   img prev-layer color font str1 str2 vertical)

  ;;; Some Utilities
  (define (one-stop-operation opr)
    (gimp-image-undo-group-start img)
    (opr)
    (gimp-image-undo-group-end img)
    (gimp-displays-flush))

;;  (define (any? proc l) (cond ((null? l) #f) ((proc (car l)) #t) (else (any? proc (cdr l)))))
  (define (all? proc l) (cond ((null? l) #t) ((not (proc (car l))) #f) (else (all? proc (cdr l)))))

  (define (make-tuple lists)
    (define (make-tuple-recur lists result)
      (cond ((all? null? lists) result)
            ('else (make-tuple-recur 
                     (map (lambda (i) (cond ((null? i) ()) ('else (cdr i)))) lists) 
                     (append result (list (map (lambda (i) (cond ((null? i) ()) ('else (car i)))) lists)))))))
    (make-tuple-recur lists ()))
    
  ;;; Main Routine
  (one-stop-operation (lambda()
    (let* ((full-str (string-append "とある" (substring (string-append str1 "  ") 0 2) "の" (substring (string-append str2 "    ") 0 4)))
           (hpositions '((0 0) (92 50) (143 45) (170 13) (272 40) (334 27)  (63 130) (159 130) (230 118) (304 113)))
           (hsizes '(128 70 50 110 80 100 90 80 90 110))
           (vpositions '((66 0) (98 73) (71 91) (79 128) (76 184) (70 229) (2 85) (23 160) (14 206) (1 255)))
           (vsizes '(80 44 44 60 60 70 70 50 55 75))
           (tuple (make-tuple (list (string->list full-str) (if vertical vpositions hpositions) (if vertical vsizes hsizes))))
          )
    (for-each (lambda (font-info) 
                (let ((char (car font-info))
                      (x (caadr font-info))
                      (y (cadadr font-info))
                      (size (caddr font-info)))
                 (gimp-text-fontname img prev-layer x y (string char) -1 TRUE size 0 font))) 
              tuple)
))))

(define (script-fu-toaru-majutsu-logo-new color font str1 str2)
  (let* ((img (car (gimp-image-new 440 350 0))))
   (script-fu-toaru-logo img -1 color font str1 str2 #f)
   (gimp-display-new img)
  )
)

(define (script-fu-toaru-kagaku-logo-new color font str1 str2)
  (let* ((img (car (gimp-image-new 150 350 0))))
   (script-fu-toaru-logo img -1 color font str1 str2 #t)
   (gimp-display-new img)
  )
)

;;; Registration
(script-fu-register "script-fu-toaru-majutsu-logo-new"
                    "とある魔術の自動生成 ..."
                    "Create logo like Toaru majutsu no Index."
                    "Sigetch <sigetch._{at}_.hotmail.com>"
                    "Sigetch"
                    "2009"
                    "RGB*, INDEXED*, GRAY*"
                    SF-COLOR     "Color"      '(0 0 0)    
                    SF-FONT      "Font"       "さざなみ明朝 Medium"    
                    SF-STRING    "Word1(2 Kanji)" "魔術"
                    SF-STRING    "Word2(4 Kanji)" "禁書目録"
)
;;; Registration
(script-fu-register "script-fu-toaru-kagaku-logo-new"
                    "とある科学の自動生成 ..."
                    "Create logo like Toaru kagaku no Railgun."
                    "Sigetch <sigetch._{at}_.hotmail.com>"
                    "Sigetch"
                    "2009"
                    "RGB*, INDEXED*, GRAY*"
                    SF-COLOR     "Color"      '(0 0 0)    
                    SF-FONT      "Font"       "さざなみ明朝 Medium"    
                    SF-STRING    "Word1(2 Kanji)" "科学"
                    SF-STRING    "Word2(4 Kanji)" "超電磁砲"
)

(script-fu-menu-register "script-fu-toaru-majutsu-logo-new" "<Image>/File/Create/Logos")
(script-fu-menu-register "script-fu-toaru-kagaku-logo-new" "<Image>/File/Create/Logos")