; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation; either version 2 of the License, or
; (at your option) any later version.
;
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
; GNU General Public License for more details.
; Change these to reasonable values
;
(define STW-default-output-dir "/home/saul/GIMP/Work/Output/")
(define STW-default-message-file "/home/saul/GIMP/Work/STW_follower_profile.csv")
; The following fontsizes are tested in order until one is found that
; allows the message to fit within the bounds of the message template
; layer. If this search is unsuccessful then the message layer is
; added using the last fontsize and the resulting image saved as an
; XCF file with "ERROR-" prepended to the name.
;
(define STW-fontsizes '(16 12 10 9 8 7 6))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Nothing below should need changing
;
(define (script-fu-sg-STW-acknowledge template-image
template-layer
output-dir
message-file
save-png
save-xcf )
; A template image must contain at least two layers with the following
; names:
(define avatar-templatename "Avatar")
(define message-templatename "Message")
; These template layers can be in one of two forms: either the layer
; has no layermask and the boundaries of the layer determine the
; location and size of the content, or the layer's mask provides
; size and location of the content (permitting the layer to be any
; arbitrary size). These template layers are typically hidden (or
; have their Opacity zeroed) but alternatively could provide a
; background.
; The avatar template layer defines the position and boundaries of where
; the user profile picture is to appear.
; Should undersized profile pictures be scaled up to entirely fill
; the avatar template region? (If #f then undersized avatars will
; be centered within the template region.)
;
(define avatar-upscale? #t)
; Should oversized profile pictures be scaled down to fit within the
; avatar template bounds?
;
(define avatar-downscale? #t)
; Read characters until end-of-line
; Note: the optional 'port' argument is only used during
; interactive debugging.
;
(define (readln . port)
(let ((getch (if (pair? port)
(lambda () (read-char (car port)))
read-char )))
(let loop ((char (getch))
(result "") )
(if (eof-object? char)
#f
(if (eqv? char #\newline)
result
(loop (getch) (string-append result (make-string 1 char))) )))))
; return bounds (xywh) of either layer or its mask
; Note: using a mask ensures cropping
;
(define (get-template-bounds layer)
(let* ((image (car (gimp-item-get-image layer)))
(mask (car (gimp-layer-get-mask layer))))
(if (= mask -1)
(list (car (gimp-drawable-offsets layer))
(cadr (gimp-drawable-offsets layer))
(car (gimp-drawable-width layer))
(car (gimp-drawable-height layer)))
(let ((orig-sel (car (gimp-selection-save image))))
(gimp-image-select-item image CHANNEL-OP-REPLACE mask)
(let* ((bounds (cdr (gimp-selection-bounds image)))
(x (car bounds))
(y (cadr bounds)))
(gimp-selection-load orig-sel)
(gimp-image-remove-channel image orig-sel)
(list x y (- (caddr bounds) x) (- (cadddr bounds) y)))))))
; scale layer to fit bounds while maintaining aspect ratio
;
(define (fit-layer layer bounds)
(let* ((x (car bounds))
(y (cadr bounds))
(w (caddr bounds))
(h (cadddr bounds))
(layer-width (car (gimp-drawable-width layer)))
(layer-height (car (gimp-drawable-height layer)))
(aspect (/ layer-height layer-width)))
(gimp-layer-add-alpha layer)
(if (< (/ w layer-width) (/ h layer-height))
(begin
(gimp-layer-scale-full layer
w
(* w aspect)
TRUE
INTERPOLATION-CUBIC)
(gimp-layer-set-offsets layer x (+ y (/ (- h (* w aspect)) 2) )))
(begin
(gimp-layer-scale-full layer
(/ h aspect)
h
TRUE
INTERPOLATION-CUBIC)
(gimp-layer-set-offsets layer (+ x (/ (- w (/ h aspect)) 2)) y)))))
(define (center-layer layer bounds)
(let* ((x (car bounds))
(y (cadr bounds))
(w (caddr bounds))
(h (cadddr bounds))
(layer-width (car (gimp-drawable-width layer)))
(layer-height (car (gimp-drawable-height layer))))
(gimp-layer-set-offsets layer
(- (+ x (/ w 2)) (/ layer-width 2))
(- (+ y (/ h 2)) (/ layer-height 2)))))
(define (retrieve-avatar dst-image src-image avatar-upscale? avatar-downscale? bounds)
(let* ((avatar (car (gimp-layer-new-from-drawable (car (gimp-image-get-active-layer src-image))
dst-image )))
(w (car (gimp-drawable-width avatar)))
(h (car (gimp-drawable-height avatar)))
(target-width (caddr bounds))
(target-height (cadddr bounds))
(aspect (/ h w)))
(gimp-image-insert-layer dst-image avatar 0 -1)
(if (or (and avatar-upscale?
(or (< w target-width)
(< h target-height)))
(and avatar-downscale?
(or (> w target-width)
(> h target-height))))
(fit-layer avatar bounds)
(center-layer avatar bounds))))
; MAIN PROCEDURE
; Retrieve the template layers
(let ((avatar-template (car (gimp-image-get-layer-by-name template-image avatar-templatename)))
(message-template (car (gimp-image-get-layer-by-name template-image message-templatename))))
(if (member -1 (list avatar-template message-template))
(gimp-message "Image is not an acknowledgement template")
(with-input-from-file message-file
(lambda ()
(readln) ; skip CSV header line
(let loop-message ((message-line (readln)))
(when message-line
(let* ((image (car (gimp-image-duplicate template-image)))
(avatar-template (car (gimp-image-get-layer-by-name image avatar-templatename)))
(message-template (car (gimp-image-get-layer-by-name image message-templatename)))
(message-info (strbreakup message-line ","))
(addressee (car message-info))
(name-text (cadr message-info))
(avatar-uri (caddr message-info))
(message-text (apply string-append (cdddr message-info)))
(message (string-append name-text ",\n" message-text)))
; Process avatar image
(let ((avatar-image (car (file-uri-load RUN-NONINTERACTIVE
(string-append name-text
".jpg")
avatar-uri
))))
(gimp-image-set-active-layer image avatar-template)
(retrieve-avatar image
avatar-image
avatar-upscale?
avatar-downscale?
(get-template-bounds avatar-template))
(gimp-item-set-name (car (gimp-image-get-active-layer image))
"Picture")
(gimp-image-delete avatar-image))
; Process message
(let ((bounds (get-template-bounds message-template)))
(let loop-message-fontsize ((fontsizes STW-fontsizes))
(let* ((fontsize (car fontsizes))
(test-layer (car (gimp-text-fontname image
-1
(car bounds)
(cadr bounds)
message
0
TRUE
fontsize
PIXELS
(car (gimp-context-get-font))))))
(gimp-text-layer-resize test-layer
(caddr bounds)
(car (gimp-image-height image)))
(gimp-text-layer-set-justification test-layer TEXT-JUSTIFY-LEFT)
(let ((message-layer (car (gimp-layer-copy test-layer TRUE))))
(plug-in-autocrop-layer RUN-NONINTERACTIVE image test-layer)
(if (and (>= (+ (car bounds) (caddr bounds))
(+ (car (gimp-drawable-offsets test-layer))
(car (gimp-drawable-width test-layer))))
(>= (+ (cadr bounds) (cadddr bounds))
(+ (cadr (gimp-drawable-offsets test-layer))
(car (gimp-drawable-height test-layer)))))
(begin ; text message fits
(gimp-image-remove-layer image test-layer)
(gimp-image-set-active-layer image message-template)
(gimp-image-insert-layer image message-layer 0 -1)
(gimp-text-layer-resize message-layer
(caddr bounds)
(cadddr bounds))
(let ((basename (string-append output-dir
DIR-SEPARATOR
addressee)))
(unless (zero? save-xcf)
(gimp-xcf-save 0
image
-1
(string-append basename ".xcf")
(string-append basename ".xcf")))
(let ((layer (car (gimp-image-flatten image))))
(if (zero? save-png)
(file-jpeg-save RUN-NONINTERACTIVE
image
layer
(string-append basename ".jpg")
(string-append basename ".jpg")
0.92 ; compression
0 ; smoothing
1 ; optimize
1 ; progressive
"" ; comment
0 ; subsmp (0-4)
1 ; baseline
0 ; restart
0 ;dct
)
(file-png-save2 RUN-NONINTERACTIVE
image
layer
(string-append basename ".png")
(string-append basename ".png")
FALSE ; interlace
9 ; compression
FALSE ; bkgd
(car (gimp-drawable-has-alpha layer))
FALSE ; offs
FALSE ; phys
FALSE ; time
TRUE ; comment
FALSE ; svtrans
))))
(gimp-image-delete image))
; text message did not fit
(if (null? (cdr fontsizes))
(begin ; No more sizes to try
(gimp-image-remove-layer image test-layer)
(gimp-image-insert-layer image message-layer 0 -1)
(let ((filename (string-append output-dir
DIR-SEPARATOR
"ERROR-"
addressee
".xcf")))
(gimp-xcf-save 0 image -1 filename filename))
(gimp-image-delete image))
(begin
(gimp-layer-delete message-layer)
(gimp-image-remove-layer image test-layer)
(loop-message-fontsize (cdr fontsizes))))))))
(loop-message (readln)))))
(let loop ((obj (read))) ; work-around for a GIMP bug
(unless (eof-object? obj)
(loop (read))))))))))
(script-fu-register "script-fu-sg-STW-acknowledge"
"Create Acknowledgementss..."
"Create STW aknowledgements from template image"
"Saul Goode"
"Saul Goode"
"December 2014"
"RGB*,GRAY*"
SF-IMAGE "Image" 0
SF-DRAWABLE "Drawable" 0
SF-DIRNAME "Output Folder" STW-default-output-dir
SF-FILENAME "Messages File" STW-default-message-file
SF-TOGGLE "Save as PNG (else JPEG)" FALSE
SF-TOGGLE "Save XCF copy" FALSE
)
(script-fu-menu-register "script-fu-sg-STW-acknowledge"
"<Image>/Filters/STW"
)