; 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-platonic-calendar edge-length
ym-layout ; 0 = y/m equal, 1=large month, 2=large year, 3=year-month, 4=month-year
; the following are common to script-fu-sg-calendar
lang year sunday? letters-in-day
layout text-font number-font font-size%
justify? gravity
use-facet-image facet-image)
; traditional atan2 function - returns angle of a line
;
(define (atan2 y x)
(if (> x 0)
(atan (/ y x))
(if (< x 0)
(if (< y 0)
(- (atan (/ y x)) *pi*)
(+ (atan (/ y x)) *pi*) )
(cond ;; x is zero
((> y 0) (/ *pi* 2))
((< y 0) (- (/ *pi* 2)))
(else ;; x==y==0 is typically undefined but we return 0 instead
0 ) ) ) ) )
(define (deg->rad x)
(/ (* x *pi*) 180) )
(define (rad->deg x)
(/ (* x 180) *pi*) )
; polar to rectangular
; Returns a pair (x . y)
;
(define (p->r rad ang)
(cons (* rad (cos (/ ang (/ 180 *pi*))))
(* rad (sin (/ ang (/ 180 *pi*)))) ))
; return a list of pairs containing the anchor points of a path's stroke
; For example, ((x0 . y0) (x1 . y1) (x2 . y2) (x3 . y3) (x4 . y4))
; If stroke is not supplied then first stroke is assumed
;
(define (get-anchors path . stroke)
(let ((stroke (if (null? stroke)
(vector-ref (cadr (gimp-vectors-get-strokes path)) 0)
(car stroke) )))
(let loop ((points (vector->list (caddr (gimp-vectors-stroke-get-points path stroke))))
(anchors '()) )
(if (null? points)
(if (null? anchors)
'()
(reverse anchors) )
(loop (cdddr (cdddr points))
(cons (cons (cadr (cdddr points)) (cadr points)) anchors) )))))
; Reverse the direction of a path's polygonal stroke. Works by creating
; a new (reversed) stroke and removing the original.
; Returns the new stroke.
; If stroke is not supplied then first stroke is assumed.
;
(define (reverse-pent path . stroke)
(let* ((stroke (if (null? stroke)
(vector-ref (cadr (gimp-vectors-get-strokes path)) 0)
(car stroke) ))
(anchors (get-anchors path stroke))
(new-stroke 0) )
; mangle list order because strokes are built in reverse order
(set! anchors (reverse (append (list (car anchors)) (reverse (cdr anchors)))))
(set! new-stroke (car (gimp-vectors-bezier-stroke-new-moveto path
(caar anchors)
(cdar anchors) )))
(gimp-vectors-remove-stroke path stroke)
(let loop ((anchors (cdr anchors)))
(if (null? anchors)
new-stroke
(begin
(gimp-vectors-bezier-stroke-lineto path new-stroke (caar anchors) (cdar anchors))
(loop (cdr anchors)) )))))
; For debugging only
; (define (print-points path)
; (let* ((stroke (vector-ref (cadr (gimp-vectors-get-strokes path)) 0)))
; (display (gimp-vectors-stroke-get-points path stroke)) ))
; Create a new pentagon (a polygonal path with five anchor points)
; xya is a list containing the x and y coordinates, and the angle (in degrees) of the first edge
; Returns the path ID of the created pentagon.
; Note: the name of the month pentagrams is their numeric index (Jan=0, Feb=1, Mar=2,...)
; Note to programmers: the bezier-stroke-line-to routine prepends new points to
; the start of the stroke!
;
(define (make-pent image name xya)
(let* ((path (car (gimp-vectors-new image name)))
(stroke 0)
(x (car xya))
(y (cadr xya))
(banner-angle (caddr xya))
(points (list (cons x y))) )
(gimp-image-add-vectors image path 0)
(let loop ((count 4)
(x (+ x (car (p->r edge-length banner-angle))))
(y (+ y (cdr (p->r edge-length banner-angle))))
(angle 72) )
(if (zero? count)
points
(begin
(set! points (cons (cons x y) points))
(loop (- count 1)
(+ x (car (p->r edge-length (+ banner-angle angle))))
(+ y (cdr (p->r edge-length (+ banner-angle angle))))
(modulo (+ angle 72) 360) ))))
(set! stroke (car (gimp-vectors-bezier-stroke-new-moveto path (caar points) (cdar points))))
(set! points (cdr points))
(while (pair? points)
(gimp-vectors-bezier-stroke-lineto path stroke (caar points) (cdar points))
(set! points (cdr points)) )
(gimp-vectors-stroke-close path stroke)
path ))
; pent-ref returns a list containing the starting xy coords and angle (in degrees) of
; the nth path segment. (This list can then be passed to make-pent.)
; (x y angle)
;
(define (pent-ref pent index)
(let* ((points (get-anchors pent))
(x0 (car (list-ref points index)))
(y0 (cdr (list-ref points index)))
(x1 (car (list-ref points (modulo (+ index 1) 5))))
(y1 (cdr (list-ref points (modulo (+ index 1) 5))))
(ang (atan2 (- y1 y0) (- x1 x0))) )
(list x0
y0
(* 180 ang (/ *pi*)) )))
; Render a month for the specified pentagon. The path's name is
; the index of the month (Jan=0, Feb=1, Mar=2,...)
; Returns the image ID of the rendered image (this image only has one layer)
;
(define (month-pent pent)
(let* ((month-image (car (gimp-image-new edge-length (ceiling (/ (* edge-length 7) 6)) RGB)))
(month-layer (car (gimp-layer-new month-image
edge-length
edge-length
RGBA-IMAGE "tmp" 100 NORMAL-MODE)))
(month (string->number (car (gimp-vectors-get-name pent)))) ; path name = month (0-11)
(month-name (list-ref (list-ref sg-calendar-months lang) month))
(date-layer 0)
(text-month 0) ; layer for month banner
(text-year 0) ; layer for year banner
(text-size 0)
(banner-height 0) )
; For debugging only !!!
; (gimp-display-new month-image)
(gimp-image-add-layer month-image month-layer 0)
(gimp-drawable-fill month-layer TRANSPARENT-FILL)
(gimp-layer-set-offsets month-layer 0 (- (car (gimp-image-height month-image))
(car (gimp-drawable-height month-layer)) ))
; draw the dates for the month
(set! date-layer (car (script-fu-sg-calendar month-image
month-layer
lang
month
year
TRUE ; Sunday first
letters-in-day
layout ; (0=allow 6, 2=force 6, 3=wrap to w1, 4=wrap to w5)
text-font
number-font
font-size% ; text size as % of cell size
justify? ; right justify single-digit numbers
0 ; no borders
'(0 0 0) ; border color (ignored)
gravity ; center date in cell
)))
(gimp-image-set-active-layer month-image date-layer)
(plug-in-autocrop-layer RUN-NONINTERACTIVE month-image date-layer)
(set! banner-height (* 0.9 (cadr (gimp-drawable-offsets date-layer))))
;; draw the banner
(if (< ym-layout 3)
; ym-layout is vertical
(let ((y/m-ratio (cond
((zero? ym-layout) 0.5)
((= 1 ym-layout) 0.35)
(else 0.60) )))
(set! text-size (sg-calendar-calc-fontsize month-name text-font 100 edge-length (* banner-height (- 1 y/m-ratio))))
(set! text-month (car (gimp-text-fontname month-image -1
0 0 month-name 0 TRUE text-size PIXELS text-font )))
(gimp-image-set-active-layer month-image text-month)
(plug-in-autocrop-layer RUN-NONINTERACTIVE month-image text-month)
(gimp-layer-set-offsets text-month
(/ (- edge-length (car (gimp-drawable-width text-month))) 2) ; center horiz
(+ (* banner-height y/m-ratio)
(/ (- (* banner-height (- 1 y/m-ratio))
(car (gimp-drawable-height text-month))) 2) ))
(set! text-size (sg-calendar-calc-fontsize (number->string year) text-font 100 edge-length (* banner-height y/m-ratio)))
(set! text-year (car (gimp-text-fontname month-image -1 0 0 (number->string year) 0 TRUE text-size PIXELS text-font)))
(gimp-image-set-active-layer month-image text-year)
(plug-in-autocrop-layer RUN-NONINTERACTIVE month-image text-year)
(gimp-layer-set-offsets text-year
(/ (- edge-length (car (gimp-drawable-width text-year))) 2)
(/ (- (cadr (gimp-drawable-offsets text-month))
(car (gimp-drawable-height text-year))) 2) )
)
; ym-layout is horizontal
(let ((ym-text (if (= 3 ym-layout)
(string-append (number->string year) " " month-name)
(string-append month-name " "(number->string year)) )))
(set! text-size (sg-calendar-calc-fontsize ym-text text-font 90 edge-length banner-height))
(set! text-year (car (gimp-text-fontname month-image -1 0 0 ym-text 0 TRUE text-size PIXELS text-font)))
(gimp-image-set-active-layer month-image text-year)
(plug-in-autocrop-layer RUN-NONINTERACTIVE month-image text-year)
(gimp-layer-set-offsets text-year
(/ (- edge-length (car (gimp-drawable-width text-year))) 2)
(/ (- (cadr (gimp-drawable-offsets date-layer))
(car (gimp-drawable-height text-year))) 2) )
)
)
(gimp-layer-resize-to-image-size month-layer)
(set! month-layer (car (gimp-image-merge-visible-layers month-image CLIP-TO-IMAGE)))
month-image
)
)
; Renders a rotated month calendar within the specified pentagon. The path's name is
; the index of the month (Jan=0, Feb=1, Mar=2,...)
;
(define (make-month target-layer pent)
(let* ((tmp-image (month-pent pent))
(xya (pent-ref pent 0))
(buffer (car (gimp-edit-named-copy (car (gimp-image-get-active-drawable tmp-image)) "tmp")))
(floated (car (gimp-edit-named-paste target-layer buffer FALSE))) )
(gimp-image-delete tmp-image)
(gimp-floating-sel-to-layer floated)
(gimp-layer-set-offsets floated (car xya) (cadr xya))
(gimp-drawable-transform-rotate floated
(deg->rad (caddr xya)) ; delta-y delta-x for end points
FALSE
(car xya) (cadr xya)
TRANSFORM-FORWARD
INTERPOLATION-CUBIC
TRUE 3 TRANSFORM-RESIZE-ADJUST )
(gimp-drawable-set-name floated
(list-ref (list-ref sg-calendar-months lang)
(string->number (car (gimp-vectors-get-name pent))) ))
)
)
(define (make-tab image name pent)
(let* ((xya (append (butlast (pent-ref pent 2)) (cddr (pent-ref pent 1))))
(tab (car (gimp-vectors-new image name)))
(stroke 0) )
(gimp-image-add-vectors image tab 0)
(set! stroke (car (gimp-vectors-bezier-stroke-new-moveto tab (car xya) (cadr xya))))
(gimp-vectors-bezier-stroke-lineto tab
stroke
(+ (car xya) (car (p->r (/ edge-length 3) (caddr xya))))
(+ (cadr xya) (cdr (p->r (/ edge-length 3) (caddr xya)))) )
(set! xya (pent-ref pent 3))
(gimp-vectors-bezier-stroke-lineto tab
stroke
(- (car xya) (car (p->r (/ edge-length 3) (caddr xya))))
(- (cadr xya) (cdr (p->r (/ edge-length 3) (caddr xya)))) )
(gimp-vectors-bezier-stroke-lineto tab
stroke
(car xya)
(cadr xya) )
(set! xya (append (butlast (pent-ref pent 3)) (cddr (pent-ref pent 2))))
(gimp-vectors-bezier-stroke-lineto tab
stroke
(+ (car xya) (car (p->r (/ edge-length 3) (caddr xya))))
(+ (cadr xya) (cdr (p->r (/ edge-length 3) (caddr xya)))) )
(set! xya (pent-ref pent 4))
(gimp-vectors-bezier-stroke-lineto tab
stroke
(- (car xya) (car (p->r (/ edge-length 3) (caddr xya))))
(- (cadr xya) (cdr (p->r (/ edge-length 3) (caddr xya)))) )
(gimp-vectors-bezier-stroke-lineto tab
stroke
(car xya)
(cadr xya) )
tab ))
;; MAIN PROCEDURE STARTS HERE
(let* ((image 0) (bg-layer 0) (folds-layer 0)
(stroke 0)
(jan 0) (feb 0) (mar 0) (apr 0) (may 0) (jun 0)
(jul 0) (aug 0) (sep 0) (oct 0) (nov 0) (dec 0)
(ref 0) (tmp 0) (tab-mar 0) (tab-apr 0) (tab-may 0) (tab-jun 0)
(months '())
(tabs '())
(xya '()) )
(set! image (car (gimp-image-new (* 6 edge-length) (* 8 edge-length) RGB)))
(gimp-display-new image)
(gimp-image-undo-disable image)
(gimp-context-push)
(set! bg-layer (car (gimp-layer-new image
(car (gimp-image-width image))
(car (gimp-image-height image))
RGB-IMAGE
"Background"
100
NORMAL-MODE )))
(gimp-image-add-layer image bg-layer 0)
(gimp-drawable-fill bg-layer WHITE-FILL)
(set! jan (make-pent image "0" (list (* 2.2 edge-length) (* 2.9 edge-length) 252)))
(set! months (cons jan months))
(set! ref (car (gimp-vectors-copy jan)))
(gimp-image-add-vectors image ref 0) ; not necessary
(gimp-vectors-set-name ref "ref")
(reverse-pent ref)
(set! feb (make-pent image "1" (pent-ref ref 0)))
(set! months (cons feb months))
(set! mar (make-pent image "2" (pent-ref ref 1)))
(set! months (cons mar months))
(set! apr (make-pent image "3" (pent-ref ref 2)))
(set! months (cons apr months))
(set! may (make-pent image "4" (pent-ref ref 3)))
(set! months (cons may months))
(set! jun (make-pent image "5" (pent-ref ref 4)))
(set! months (cons jun months))
(gimp-image-remove-vectors image ref)
(set! ref (car (gimp-vectors-copy feb)))
(gimp-image-add-vectors image ref 0) ; not necessary
(gimp-vectors-set-name ref "ref")
(reverse-pent ref)
(set! tmp (make-pent image "tmp" (pent-ref ref 2)))
(gimp-image-remove-vectors image ref)
(set! ref (car (gimp-vectors-copy tmp)))
(gimp-image-remove-vectors image tmp)
(gimp-image-add-vectors image ref 0) ; not necessary
(gimp-vectors-set-name ref "ref")
(reverse-pent ref)
(set! dec (make-pent image "11" (pent-ref ref 1)))
(set! months (cons dec months))
(gimp-image-remove-vectors image ref)
(set! ref (car (gimp-vectors-copy dec)))
(gimp-image-add-vectors image ref 0) ; not necessary
(gimp-vectors-set-name ref "ref")
(reverse-pent ref)
(set! jul (make-pent image "6" (pent-ref ref 1)))
(set! months (cons jul months))
(set! aug (make-pent image "7" (pent-ref ref 2)))
(set! months (cons aug months))
(set! sep (make-pent image "8" (pent-ref ref 3)))
(set! months (cons sep months))
(set! oct (make-pent image "9" (pent-ref ref 4)))
(set! months (cons oct months))
(set! nov (make-pent image "10" (pent-ref ref 0)))
(set! months (cons nov months))
(gimp-image-remove-vectors image ref)
(set! tab-jun (make-tab image "tab-jun" jun))
(set! tabs (cons tab-jun tabs))
(set! tab-may (make-tab image "tab-may" may))
(set! tabs (cons tab-may tabs))
(set! tab-apr (make-tab image "tab-apr" apr))
(set! tabs (cons tab-apr tabs))
(set! tab-mar (make-tab image "tab-mar" mar))
(set! tabs (cons tab-mar tabs))
(map (lambda (month) (make-month bg-layer month)) months)
(gimp-context-set-paint-method "gimp-paintbrush")
(gimp-context-set-foreground '(128 128 128))
(gimp-context-set-brush "Circle (01)")
(set! folds-layer (car (gimp-layer-new image
(car (gimp-image-width image))
(car (gimp-image-height image))
RGBA-IMAGE
"Folds"
100
NORMAL-MODE )))
(gimp-image-add-layer image folds-layer 0)
(gimp-drawable-fill folds-layer TRANSPARENT-FILL)
(map (lambda (path)
(gimp-edit-stroke-vectors folds-layer path))
(append tabs months) )
(gimp-context-pop)
(gimp-image-undo-enable image)
(gimp-displays-flush)
)
)
(script-fu-register "script-fu-sg-platonic-calendar"
"Platonic calendar..."
"Generate a dodecahedron with a monthly calendar on each face"
"Saul Goode"
"Saul Goode"
"updated Jan 2011"
""
SF-ADJUSTMENT "Edge length" '(450 100 1500 1 10 0 1)
SF-OPTION "Banner format" '("Year/Month equal size" "Large Month" "Large Year"
"Year Month (horiz)" "Month Year(horiz)")
SF-OPTION "Language" '("English" "German" "Italian" "Spanish" "French")
SF-ADJUSTMENT "Year" '( 2011 1753 2050 1 10 0 1 )
SF-TOGGLE "Sunday first" TRUE
SF-OPTION "Day format" '("S M T ..." "Su Mo Tu ..." "Sun Mon Tue ...")
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 "Text font" "Sans"
SF-FONT "Number font" "Sans"
SF-ADJUSTMENT "Font Size (% of maximum)" '( 100 0 100 1 10 0 1)
SF-TOGGLE "Right Justify" TRUE
SF-OPTION "Date Position" '( "top-left" "top-center" "top-right" "left-center" "center" "right-center" "bottom-left" "bottom-center" "bottom-right")
SF-TOGGLE "Use facet image" FALSE
SF-IMAGE "Image" 0
)
(script-fu-menu-register "script-fu-sg-platonic-calendar"
"<Image>/File/Create"
)
; (script-fu-sg-platonic-calendar 450 0 0 2011 TRUE 0 0 "Sans" "Sans" 100 TRUE 0 FALSE 0)