Script-Fu: resize, combine, vectors, regexp

Текущая библиотека разных моих мелких функций на Скрипт-Фу. Очень жаль, что Блогспот не даёт прикладывать файлы в виде файлов целиком.

;
; Расширения Script-Fu
;

; Возвращает список файлов из dir
; Пример: (hl-file-list "/tmp")
(define (hl-file-list dir) 
  (cadr (file-glob (string-append dir "/*") 0)))

; Загрузить файл jpg
; Пример: (hl-jpeg-load "/tmp/butt/video1.jpg")
; Возвращает: image
(define (hl-jpeg-load filename)
  (car (file-jpeg-load RUN-NONINTERACTIVE filename filename)))

; Склеить вертикально два одинаковых по размеру файла jpg в один
(define (hl-jpeg-vcombine file1 file2 file3)
(let* (
    (img1 (hl-jpeg-load file1))
    (img2 (hl-jpeg-load file2))
    (h-height (car (gimp-image-height img1)))
    (f-width (car (gimp-image-width img1)))
    ; Создадим "подложку"
    (img (car (gimp-image-new f-width (* h-height 2) RGB)))
    ; Обозначим локальные переменные
    (dra) (dra-copy))
  ; Снимем копию дравабле первого файла и добавим её
  ; в верхнюю часть подложки
  (set! dra-copy (car (gimp-image-get-active-layer img1)))
  (set! dra-copy (car (gimp-layer-new-from-drawable dra-copy img)))
  (gimp-image-add-layer img dra-copy -1)
  ; Добавим копию второго имаге вниз подложки
  (set! dra-copy (car (gimp-image-get-active-layer img2)))
  (set! dra-copy (car (gimp-layer-new-from-drawable dra-copy img)))
  (gimp-image-add-layer img dra-copy -1)
  (gimp-layer-set-offsets dra-copy 0 h-height)
  ; Сохраним изображение в file3
  (set! dra (car (gimp-image-merge-visible-layers img 0)))
  (file-png-save 1 img dra file3 file3 0 9 0 0 0 1 1)
  ; Подчистим за собой мусор
  (hl-delete-images (list img img1 img2))))

; Удаляет загруженные изображения из памяти
(define (hl-delete-images image-list)
  (map (lambda (x) (gimp-image-delete x)) image-list))

; Уменьшить размеры jpg. new-len: новая длина стороны
; flag: "w" или "h", смотря по какой стороне ориентироваться с размерами
(define (hl-resize-jpg file-in file-out new-len flag)
(let* (
    (img (car (file-jpeg-load 1 file-in file-in)))
    (dra (car (gimp-image-get-active-layer img)))
    (old-h (car (gimp-image-height img)))
    (old-w (car (gimp-image-width img)))
    (new-h) (new-w))
  ; Вычислим новые размеры картинки
  (if (string=? flag "w")
    (begin
      (set! new-w new-len)
      (set! new-h (* old-h (/ new-w old-w))))
    (begin
      (set! new-h new-len)
      (set! new-w (* old-w (/ new-h old-h)))))
  ; Изменим размеры jpg
  (gimp-drawable-transform-scale dra 0 0 new-w new-h 0 3 FALSE 3 2)
  (gimp-image-crop img new-w new-h 0 0)
  ; Сохраним картинку
  (file-jpeg-save 1 img dra file-out file-out .95 0 0 0 " " 0 1 0 1)
  ; Очистим мусор
  (gimp-image-delete img)))

; Создать картинку размерами x y
(define (hl-make-image x y)
(let* (
    (img (car (gimp-image-new x y RGB)))
    (dra (car (gimp-layer-new img x y RGB-IMAGE "Background" 100  NORMAL-MODE))))
  (gimp-image-add-layer img dra -1)
  (gimp-edit-clear dra)
  (list img dra)))

; Выбрать область с закруглёнными краями
(define (hl-select-round img x y ox oy)
  (gimp-rect-select img x y ox oy REPLACE FALSE 0)
  (script-fu-selection-rounded-rectangle img FALSE 50 FALSE))

;
; Расширения TinyScheme
;

; Отрезает последние num символов от строки
(define (chop str num)
  (substring str 0 (- (string-length str) num)))

; Проверяет, принадлежит ли значение списку
; Пример: (in-list? 3 '(1 2 3 4 5 6))
(define (in-list? itm lst)
(let* (
    (found 0))
  (for-each (lambda (x)
    (if ((if (string? x) string=? =) x itm) (set! found (+ found 1))))
    lst)
  (if (> found 0) #t #f)))

; Возвращает уникальные значения списка
(define (unique lst)
(let* (
    (out-list '()))
  (for-each (lambda (x) 
    (if (in-list? x out-list) #f (set! out-list (append out-list (list x)))))
    lst)
  out-list))

; Вырезать имя файла из полного пути
; (hl-filename "/tmp/test.jpg") -> "test.jpg"
(define (hl-filename path)
(let* (
    (f-len (string-length path))
    (s-len 1))
  (while (and 
      (<= s-len f-len) 
      (not (re-match "/" (substring path (- f-len s-len)))))
    (set! s-len (+ s-len 1)))
  (substring path (+ (- f-len s-len) 1))))

;
; Рабочие процедуры
;

; Загрузить кучу кнопок вида "test1.jpg" и "test2.jpg", изменить их
; размер до 54 по вертикали, склеить их попарно в файлы для rollover
; кнопок на сайте.
(define (hl-resize-buttons)
(let* (
    (in-dir "/home/oleg/gimp/indir")
    (out-dir "/home/oleg/gimp/outdir")
    ; В button-list лежит список файлов типа '("test", "about", "home")
    (button-list (unique (map hl-filename (map 
      (lambda (x) (chop x 5)) (hl-file-list in-dir))))))
  (for-each (lambda (x)
      ; Делаем ресайз кнопок
      (hl-resize-jpg (string-append in-dir "/" x "1.jpg")
        (string-append out-dir "/" x "1.jpg") 54 "h")
      (hl-resize-jpg (string-append in-dir "/" x "2.jpg")
        (string-append out-dir "/" x "2.jpg") 54 "h")
      (hl-jpeg-vcombine
        (string-append out-dir "/" x "1.jpg")
        (string-append out-dir "/" x "2.jpg")
        (string-append out-dir "/" x ".png")))
    button-list)))

; Сделать кнопку в стиле веб-два-ноль с заданным текстом
; (hl-button "Нажмите здесь!" "Courier" "sample.png" '(224 224 255) '(80 80 255) '(255 255 255))
; Цвета (1-2-3): фон, цвет кнопки, цвет текста
(define (hl-button text font name color-1 color-2 color-3)
(let* (
    (tx (car (gimp-text-get-extents-fontname text 26 0 font)))
    (ty (cadr (gimp-text-get-extents-fontname text 26 0 font)))
    (image (nl-make-image (+ tx 44) 44)))

  ; Очищаем фон, ставим бэкграунд
  (gimp-context-set-foreground color-1)
  (gimp-edit-fill (cadr image) 0)
  (gimp-context-set-background color-1)

  ; Заполняем большой прямоугольник
  (hl-select-round (car image) 4 4 (+ tx 30) ty)
  (gimp-context-set-foreground color-2)
  (gimp-edit-fill (cadr image) 0)

  ; Отбрасываем тень
  (script-fu-drop-shadow (car image) (cadr image) 4 4 6 color-2 80 0)

  ; Заполняем малый прямоугольник градиентом
  (hl-select-round (car image) 6 6 (+ tx 26) (- ty 12))
  (gimp-blend (cadr image) FG-BG-RGB-MODE NORMAL-MODE GRADIENT-LINEAR
    100 0 REPEAT-NONE FALSE FALSE 0 0 FALSE 0 (- ty 12) 0 -26)

  ; Добавляем текст
  (gimp-context-set-foreground color-3)
  (gimp-text-fontname (car image) (cadr image) 19 4 text 0 TRUE 26 1 font)

  ; Сохраняем файл
  (gimp-image-merge-visible-layers (car image) 0)
  (file-png-save 1 
    (car image)
    (car (gimp-image-get-active-layer (car image))) 
    name
    name
    0 9 0 0 0 1 1)

  ; Удаляем изображение из памяти
  (gimp-image-delete (car image))))

; Нарисовать карандаш 24х24 пиксела
; Работаем с векторами и кривыми Безье. Сделав всё в 
; векторном виде, закрашиваем и изменяем размер с 240х240 до 24х24
; Получается а-ля-иконка
(define (hl-pencil)
(let* (
    (img (hl-make-image 240 240))
    (image (car img))
    (layer (cadr img))
    (pbody 0)
    (stro 0)
    (nose 0))

  ; Очищаем фон
  (gimp-context-set-foreground '(244 244 255))
  (gimp-edit-fill layer 0)

  ; Задаём цвет карандаша
  (gimp-context-set-foreground '(0 0 255))

  ; Новые вектора
  (set! pbody (car (gimp-vectors-new image "pencil")))
  (gimp-image-add-vectors image pbody -1)

  ; Рисуем туловище карандаша
  (set! stro (car (gimp-vectors-bezier-stroke-new-moveto pbody 180 20)))
  (gimp-vectors-bezier-stroke-lineto pbody stro 70 130)
  (gimp-vectors-bezier-stroke-conicto pbody stro 105 135 110 170)
  (gimp-vectors-bezier-stroke-lineto pbody stro 220 60)
  (gimp-vectors-bezier-stroke-conicto pbody stro 215 25 180 20)

  ; Закрашиваем туловище
  (gimp-vectors-to-selection pbody 0 TRUE FALSE 0 0)
  (gimp-blend layer FG-BG-RGB-MODE NORMAL-MODE GRADIENT-LINEAR
    100 0 REPEAT-NONE FALSE FALSE 0 0 FALSE 125 75 240 240)
  (gimp-selection-none image)

  ; Рисуем носик карандаша
  (set! nose (car (gimp-vectors-new image "pencil")))
  (gimp-image-add-vectors image nose -1)
  (set! stro (car (gimp-vectors-bezier-stroke-new-moveto nose 70 130)))
  (gimp-vectors-bezier-stroke-lineto nose stro 20 220)
  (gimp-vectors-bezier-stroke-lineto nose stro 110 170)
  (gimp-vectors-bezier-stroke-conicto nose stro 105 135 70 130)

  ; Закрашиваем носик
  (gimp-vectors-to-selection nose 0 TRUE FALSE 0 0)
  (gimp-blend layer FG-BG-RGB-MODE NORMAL-MODE GRADIENT-LINEAR
    100 0 REPEAT-NONE FALSE FALSE 0 0 FALSE -30 30 170 230)
  (gimp-selection-none image)

  ; Изменяем размер
  (gimp-image-scale image 24 24)

  (gimp-display-new image)))

;
; Отладочные участки
;

; Показываем изображение
; (gimp-display-new img)

; Список шрифтов (можно напамить на него hl-button)
; (gimp-fonts-get-list "")

; Отштриховываем вектора
; (gimp-context-set-brush "Circle (03)")
; (gimp-context-set-foreground '(0 0 255))
; (gimp-edit-stroke-vectors layer nose)