GIMP Script-fu

Artifact Content
Login

Artifact 007bbbd31c5bb5c9e6aa105b84136f906c45a2cd:


; 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"
  )