Artifact 42df9f8071d280d420b0f41caed9990358969d79:
- File
sg-calendar-year.scm
— part of check-in
[0485924ef1]
at
2010-12-28 17:03:05
on branch sg-calendar-year
— Initial beta version of script. Works but is untested.
20110109 - branch closed (code moved to sg-calendar branch) (user: saul size: 7203)
; 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. (define (script-fu-sg-calendar-year orig-image orig-drawable year num-cols padding sunday? layout font fontsize% justify? border border-color gravity) ;; Perform a crude search for the largest font that will fit within ;; the given dimensions ; (define (calc-fontsize text font fontsize% width height) (let* ((fontsize 6) ;; minimum possible fontsize (extents nil) (last-extents nil) (last-fontsize 3) (adjust 2) ) (set! extents (gimp-text-get-extents-fontname text fontsize PIXELS font)) (set! width (* width fontsize% 0.01)) (set! height (* height fontsize% 0.01)) (while (and (<> last-fontsize fontsize) (not (equal? extents last-extents))) (if (or (> (car extents) width) (> (cadr extents) height)) (begin (set! fontsize last-fontsize) (set! adjust (+ (* (- adjust 1) 0.5) 1)) ) (begin (set! last-extents extents) (set! last-fontsize fontsize) ) ) (set! fontsize (truncate (* fontsize adjust))) (set! extents (gimp-text-get-extents-fontname text fontsize PIXELS font)) ) (max fontsize 6) ) ) (let* ((image 0) (orig-x (car (gimp-drawable-offsets orig-drawable))) (orig-y (cadr (gimp-drawable-offsets orig-drawable))) (orig-sel 0) (bounds (gimp-drawable-mask-intersect orig-drawable)) (buffer "") (layer 0) (display 0) ) (gimp-image-undo-group-start orig-image) (set! orig-sel (car (gimp-selection-save orig-image))) (unless (zero? (car bounds)) (set! bounds (cdr bounds)) (set! orig-x (car bounds)) (set! orig-y (cadr bounds)) (gimp-rect-select orig-image orig-x orig-y (caddr bounds) (cadddr bounds) CHANNEL-OP-REPLACE FALSE 0) ) (set! buffer (car (gimp-edit-named-copy orig-drawable "buffer"))) (set! image (car (gimp-edit-named-paste-as-new buffer))) (gimp-image-undo-disable image) (set! display (car (gimp-display-new image))) (set! layer (car (gimp-image-get-active-layer image))) (gimp-buffer-delete buffer) (let* ((x1 0) (y1 0) (x2 (car (gimp-drawable-width layer))) (y2 (car (gimp-drawable-height layer))) (width (- x2 x1)) (height (- y2 y1)) (x x1) (y y1) (w (/ width num-cols)) (h (/ height (ceiling (/ 12 num-cols)))) (pad-factor (/ (- 100 padding) 100)) (w-l (* w pad-factor)) (h-l (* w pad-factor)) (temp-layer 0) (month 0) (month-fontsize 6) (extents '()) ) (when (< h (/ h-l pad-factor)) ; need to shrink calendar width (set! h-l (* h (* pad-factor 0.9))) ; increase vertical padding a bit (set! w-l h-l) ) (set! month-fontsize (apply min (map (lambda (text) (calc-fontsize text font 100 w-l (- h h-l)) ) sg-calendar-months ) ) ) (while (< y y2) (while (and (< x x2) (< month 12)) (gimp-rect-select image (+ x (/ (- w w-l) 2)) (+ y (- h h-l)) w-l h-l CHANNEL-OP-REPLACE FALSE 0) (set! buffer (car (gimp-edit-named-copy layer "buffer"))) (gimp-floating-sel-to-layer (car (gimp-edit-named-paste layer buffer FALSE))) (set! temp-layer (car (gimp-image-get-active-layer image))) (gimp-buffer-delete buffer) (script-fu-sg-calendar image temp-layer month year sunday? layout font fontsize% justify? border border-color gravity) (gimp-image-remove-layer image temp-layer) (set! extents (gimp-text-get-extents-fontname (list-ref sg-calendar-months month) month-fontsize PIXELS font )) (set! temp-layer (car (gimp-text-fontname image -1 (+ x (/ (- w (car extents)) 2)) (- (+ y (- h h-l)) (cadr extents) 2) (list-ref sg-calendar-months month) 0 FALSE month-fontsize PIXELS font ))) (set! x (+ x w)) (set! month (+ month 1)) ) (set! x x1) (set! y (+ y h)) ) ) ;; Now, transfer the rendered layers to original image (gimp-selection-none image) (let loop ((layers (cdr (reverse (vector->list (cadr (gimp-image-get-layers image)))))) (target-layer orig-drawable) ) (if (null? layers) #t (begin (let ((x (car (gimp-drawable-offsets (car layers)))) (y (cadr (gimp-drawable-offsets (car layers)))) (pos (car (gimp-image-get-layer-position orig-image target-layer))) ) (set! target-layer (car (gimp-layer-new-from-drawable (car layers) orig-image))) (gimp-image-add-layer orig-image target-layer pos) (gimp-layer-set-offsets target-layer (+ orig-x x) (+ orig-y y)) ) (loop (cdr layers) target-layer) ) ) ) (gimp-selection-load orig-sel) (gimp-image-remove-channel orig-image orig-sel) (gimp-image-set-active-layer orig-image orig-drawable) (gimp-image-undo-group-end orig-image) (gimp-display-delete display) (gimp-displays-flush) ) ) (script-fu-register "script-fu-sg-calendar-year" "Calendar year..." "Generate a calendar for current layer" "Saul Goode" "Saul Goode" "Dec 2010" "RGB*,GRAY*" SF-IMAGE "Image" 0 SF-DRAWABLE "Drawable" 0 SF-ADJUSTMENT "Year" '( 2011 1753 2050 1 10 0 1 ) SF-ADJUSTMENT "Columns" '( 4 1 12 1 10 0 1 ) SF-ADJUSTMENT "Padding" '( 10 0 80 1 10 0 1 ) SF-TOGGLE "Sunday first" TRUE SF-OPTION "Layout" '( "Allow 6-week span" "Force 6-week span" "Wrap Week 6 to Week 1" "Wrap Week 6 to Week 5") SF-FONT "Font" "Sans" SF-ADJUSTMENT "Font Size (% of maximum)" '( 100 0 100 1 10 0 1) SF-TOGGLE "Right Justify" TRUE SF-ADJUSTMENT "Border width" '( 1 0 5 1 1 0 1 ) SF-COLOR "Border color" '(0 0 0) SF-OPTION "Date Position" '( "top-left" "top-center" "top-right" "left-center" "center" "right-center" "bottom-left" "bottom-center" "bottom-right") ) (script-fu-menu-register "script-fu-sg-calendar-year" "<Image>/Filters/Render" )