; 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-projection-to-dodecahedron orig-image orig-drawable)
; 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 to programmers: the bezier-stroke-line-to routine prepends new points to
; the start of the stroke!
;
(define (make-pent image name xya edge-length)
(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*)) )))
; Renders a properly sized and rotated facet from the given facet image.
; If the facet image has more than one layer, those layers are
; "cycled through" bottom-to-top (repeated if necessary).
; If the source layer is not chain linked, it will be resized to fit
; the facet (centered); else the upper-left region of the layer is used.
;
(define (copy-facets target-image target-layer orig-image facets pents edge-length)
(let* ((x (ceiling (* edge-length (cos (deg->rad 72)))))
(width (+ 1 edge-length (* 2 x)))
(height (ceiling (+ 1 (* edge-length (+ (cos (deg->rad 18)) (sin (deg->rad 36)))))))
(image (car (gimp-image-new width height RGB)))
(layer (car (gimp-layer-new image width height RGB-IMAGE "target" 100 NORMAL-MODE)))
(frame (make-pent image "tmp" (list x 0 0) edge-length))
(xya '())
(buffer "")
(floated 0)
(tmp-layer 0)
(channel 0)
(new-facets '()) )
(gimp-image-undo-freeze orig-image)
(set! channel (car (gimp-selection-save orig-image)))
(gimp-selection-none orig-image)
(gimp-image-add-layer image layer 0)
(while (pair? pents)
(set! xya (pent-ref (car pents) 0))
(set! buffer (car (gimp-edit-named-copy (car facets) "tmp")))
(set! tmp-layer (car (gimp-edit-named-paste layer buffer FALSE)))
(gimp-buffer-delete buffer)
(gimp-floating-sel-to-layer tmp-layer)
(when (zero? (car (gimp-drawable-get-linked (car facets))))
(let* ((layer-width (car (gimp-drawable-width tmp-layer)))
(layer-height (car (gimp-drawable-height tmp-layer)))
(aspect (/ layer-height layer-width)) )
(if (> (/ width layer-width) (/ height layer-height))
(begin
(gimp-layer-scale-full tmp-layer
width
(* width aspect)
TRUE
INTERPOLATION-LANCZOS)
(gimp-layer-set-offsets tmp-layer 0 (/ (- height (* width aspect)) 2)) )
(begin
(gimp-layer-scale-full tmp-layer
(/ height aspect)
height
TRUE
INTERPOLATION-LANCZOS)
(gimp-layer-set-offsets tmp-layer (/ (- width (/ height aspect)) 2) 0) ))))
(gimp-vectors-to-selection frame CHANNEL-OP-REPLACE TRUE FALSE 0 0)
(set! buffer (car (gimp-edit-named-copy tmp-layer "tmp")))
(set! floated (car (gimp-edit-named-paste target-layer buffer FALSE)))
(gimp-buffer-delete buffer)
(gimp-floating-sel-to-layer floated)
(gimp-layer-set-offsets floated (- (car xya) x) (cadr xya))
(gimp-drawable-transform-rotate floated
(deg->rad (caddr xya)) ; delta-y delta-x for end points
FALSE
(+ (car xya) 0) (cadr xya)
TRANSFORM-FORWARD
INTERPOLATION-CUBIC
TRUE 3 TRANSFORM-RESIZE-ADJUST )
(gimp-drawable-set-name floated (car (gimp-drawable-get-name (car facets))))
(gimp-image-lower-layer-to-bottom target-image floated)
(gimp-image-raise-layer target-image floated)
(set! new-facets (cons floated new-facets))
(set! pents (cdr pents))
(set! facets (cdr facets))
)
(gimp-image-delete image)
(gimp-selection-load channel)
(gimp-image-remove-channel orig-image channel)
(gimp-image-undo-thaw orig-image)
new-facets
)
)
(define (make-tab image name pent edge-length)
(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 ))
;; Wrapper of the map object plug-in which only requires the parameters
;; the parameters that change in this particular usage.
;;
(define (fu-map-sphere image layer zoom rot-y rot-z)
(plug-in-map-object RUN-NONINTERACTIVE
image
layer
1 ; maptype (sphere)
0.5 0.5 2 ; viewpoint (0.5 0.5 2)
0.5 0.5 (- zoom) ; object position (0.5 0.5 0.0)
0 0 -1 ; first axis of object (0 0 0)
0 1 0 ; secondaxis of object (0 0 0)
0 rot-y rot-z ; rotationangle
2 ; lighttype (none)
'(255 255 255) ; lightcolor
-0.5 -0.5 2.0 ; lightposition
0 0 0 ; lightdirection
0.3 ; ambient-intensity
1.0 ; diffuse-intensity
0.5 ; diffuse-reflectivity
0.5 ; specular-reflectivity
27.0 ; highlight (note: it's exponential)
TRUE ; antialiasing
FALSE ; tiled
FALSE ; newimage
TRUE ; transparentbackground
1.0 ; radius (for CYLINDER)
0.5 0.5 0.5 ; x-scale y-scale z-scale (for BOX)
1.0 ; cylinder-length
layer ; box-front-drawable
layer ; box-back-drawable
layer ; box-top-drawable
layer ; box-bottom-drawable
layer ; box-left-drawable
layer ; box-right-drawable
layer ; cyl-top-drawable
layer ; cyl-bottom-drawable
))
;; MAIN PROCEDURE STARTS HERE
(let* ((edge-length 400)
(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) ; 12 faces are named after the months
(ref 0) (tmp 0) (tab-mar 0) (tab-apr 0) (tab-may 0) (tab-jun 0)
(pents '())
(tabs '())
(xya '())
(facets '())
(facet-layers '())
(surface-layer 0)
(text-layer 0)
(orig-sel 0) )
(set! image (car (gimp-image-new (* 6 edge-length) (* 8 edge-length) RGB)))
(gimp-image-undo-disable image)
(gimp-image-undo-freeze orig-image)
(set! orig-sel (car (gimp-selection-save orig-image)))
(gimp-selection-none orig-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 BACKGROUND-FILL)
(set! jan (make-pent image "0" (list (* 2.2 edge-length) (* 2.9 edge-length) 252) edge-length))
(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) edge-length))
(set! mar (make-pent image "2" (pent-ref ref 1) edge-length))
(set! apr (make-pent image "3" (pent-ref ref 2) edge-length))
(set! may (make-pent image "4" (pent-ref ref 3) edge-length))
(set! jun (make-pent image "5" (pent-ref ref 4) edge-length))
(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) edge-length))
(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) edge-length))
(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) edge-length))
(set! aug (make-pent image "7" (pent-ref ref 2) edge-length))
(set! sep (make-pent image "8" (pent-ref ref 3) edge-length))
(set! oct (make-pent image "9" (pent-ref ref 4) edge-length))
(set! nov (make-pent image "10" (pent-ref ref 0) edge-length))
(gimp-image-remove-vectors image ref)
(set! pents (list jan feb mar apr may jun jul aug sep oct nov dec))
(set! tab-jun (make-tab image "tab-jun" jun edge-length))
(set! tabs (cons tab-jun tabs))
(set! tab-may (make-tab image "tab-may" may edge-length))
(set! tabs (cons tab-may tabs))
(set! tab-apr (make-tab image "tab-apr" apr edge-length))
(set! tabs (cons tab-apr tabs))
(set! tab-mar (make-tab image "tab-mar" mar edge-length))
(set! tabs (cons tab-mar tabs))
(let* ((facet-layer 0)
(facet-layers '())
(count 0)
(rot-Ys '( -108 ; north pole
0 -72 -144 144 72
-72 0 72 144 -144
-36 ; south pole
))
(rot-Zs (append (list 90) ; north pole
(make-list 5 27.7)
(make-list 5 (+ 27.7 180))
(list -90) ; south pole
)))
(while (< count 12)
(set! facet-layer (car (gimp-layer-copy orig-drawable TRUE)))
(gimp-image-add-layer orig-image facet-layer 1)
(gimp-drawable-set-name facet-layer (number->string count))
(fu-map-sphere orig-image facet-layer 1.46 (car rot-Ys) (car rot-Zs))
(let* ((height (car (gimp-drawable-height facet-layer))))
(gimp-layer-resize facet-layer
(car (gimp-drawable-width facet-layer))
(* height 0.88)
0
(- (* height 0.88) height)
))
(set! facet-layers (cons facet-layer facet-layers))
(set! rot-Ys (cdr rot-Ys))
(set! rot-Zs (cdr rot-Zs))
(set! count (+ count 1)) )
(set! facets (reverse facet-layers))
(copy-facets image bg-layer orig-image facets pents edge-length) )
(gimp-display-new image)
; we are done with original image
(gimp-selection-load orig-sel)
(gimp-image-remove-channel orig-image orig-sel)
(map (lambda (x) (gimp-image-remove-layer orig-image x)) facets)
(gimp-image-undo-thaw orig-image)
(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 pents) )
(map (lambda (layer) (gimp-drawable-set-visible layer FALSE))
(vector->list (cadr (gimp-image-get-layers image))) )
(map (lambda (layer) (gimp-drawable-set-visible layer TRUE))
facet-layers )
(set! surface-layer (car (gimp-image-merge-visible-layers image EXPAND-AS-NECESSARY)))
(gimp-drawable-set-name surface-layer "All facets")
(gimp-layer-resize-to-image-size surface-layer)
(gimp-drawable-set-visible surface-layer FALSE)
(map (lambda (layer) (gimp-drawable-set-visible layer TRUE))
(vector->list (cadr (gimp-image-get-layers image))) )
(gimp-image-set-active-layer image bg-layer)
(gimp-selection-none image)
(gimp-context-pop)
(gimp-image-undo-enable image)
(gimp-displays-flush)
)
)
(script-fu-register "script-fu-sg-projection-to-dodecahedron"
"Projection to Dodecahedron"
"Generate a dodecahedron \"globe\" from a projection map"
"Saul Goode"
"Saul Goode"
"Jan 2011"
"RGB*,GRAY*"
SF-IMAGE "Image" 0
SF-DRAWABLE "Drawable" 0
)
(script-fu-menu-register "script-fu-sg-projection-to-dodecahedron"
"<Image>/Filters/Map"
)