DELETED sg-align-down.scm Index: sg-align-down.scm ================================================================== --- sg-align-down.scm +++ sg-align-down.scm @@ -1,116 +0,0 @@ -; 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-align-down image drawable) - ;; Search for the first layer that is visible below the active layer - ;; return #f on failure (no such layer) - ; - (define (get-base-layer layer) - (let - loop ((layers (cdr (memv layer (vector->list (cadr (gimp-image-get-layers image))))))) - (if (null? layers) - #f - (if (= (car (gimp-drawable-get-visible (car layers))) TRUE) - (car layers) - (loop (cdr layers)))))) - (if (or (= (car (gimp-drawable-is-layer drawable)) TRUE) - (= (car (gimp-drawable-is-layer-mask drawable)) TRUE) ) - (let* ((layer (car (gimp-image-get-active-layer image))) - (width (car (gimp-drawable-width layer))) - (height (car (gimp-drawable-height layer))) - (bounds (gimp-selection-bounds image)) - (base-layer (get-base-layer layer)) - (base-x 0) - (base-y 0) - (base-width (car (gimp-image-width image))) - (base-height (car (gimp-image-height image)))) - (if (= (car bounds) TRUE) - (begin - (set! bounds (cdr bounds)) - (set! base-x (car bounds)) - (set! base-y (cadr bounds)) - (set! base-width (- (caddr bounds) base-x)) - (set! base-height (- (cadddr bounds) base-y)) - ) - (when base-layer - (set! base-x (car (gimp-drawable-offsets base-layer))) - (set! base-y (cadr (gimp-drawable-offsets base-layer))) - (set! base-width (car (gimp-drawable-width base-layer))) - (set! base-height (car (gimp-drawable-height base-layer))) - ) - ) - (gimp-image-undo-group-start image) - (gimp-layer-set-offsets layer - (- (+ base-x (/ base-width 2)) (/ width 2)) - (- (+ base-y (/ base-height 2)) (/ height 2))) - (gimp-image-undo-group-end image) - (gimp-displays-flush) - ) - (begin ;; ELSE active drawable is a channel, center selection on image - (gimp-image-undo-group-start image) - (let ((orig-sel (if (zero? (car (gimp-selection-is-empty image))) - (car (gimp-selection-save image)) - #f )) - (channel 0) ) - (if orig-sel - (set! channel (car (gimp-selection-save image))) - (begin - (set! channel (car (gimp-channel-copy drawable))) - (gimp-image-add-channel image channel -1) )) - (gimp-selection-load channel) ;; !!! BUG = unable to load from quickmask - (let* ((bounds (gimp-selection-bounds image)) - (x (cadr bounds)) - (y (caddr bounds)) - (width (- (cadddr bounds) x)) - (height (- (car (cddddr bounds)) y)) - (image-width (car (gimp-image-width image))) - (image-height (car (gimp-image-height image))) ) - (gimp-selection-none image) - (unless (zero? (car bounds)) ;; do nothing if channel is empty - (gimp-drawable-offset channel - TRUE - OFFSET-BACKGROUND - (- (/ (- image-width width) 2) x) - (- (/ (- image-height height) 2) y) ))) - (if orig-sel - (begin - (gimp-selection-load channel) - (gimp-image-remove-channel image orig-sel) ) - (let ((buffer (car (gimp-edit-named-copy channel "temp")))) - (gimp-floating-sel-anchor (car (gimp-edit-named-paste drawable buffer FALSE))) - (gimp-buffer-delete buffer) )) - (gimp-image-remove-channel image channel) - ) - (gimp-image-undo-group-end image) - (gimp-displays-flush) - ) - ) - ) - -(script-fu-register "script-fu-sg-align-down" - "Align Down" - "Align this layer centered with the (visible) layer below it" - "Saul Goode" - "Saul Goode" - "4/9/2010" - "*" - SF-IMAGE "Image" 0 - SF-DRAWABLE "Layer" 0 - ) - -(script-fu-menu-register "script-fu-sg-align-down" - "/Layer" - ) - -(script-fu-menu-register "script-fu-sg-align-down" - "" - ) - - DELETED sg-anti-crop.scm Index: sg-anti-crop.scm ================================================================== --- sg-anti-crop.scm +++ sg-anti-crop.scm @@ -1,147 +0,0 @@ -; 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. -; -; The GNU Public License is available at -; http://www.gnu.org/copyleft/gpl.html - -(define (script-fu-sg-anti-crop image drawable) - - ;; Routine that selects box using image coordinates - (define (sel-box img box) - (gimp-rect-select img (car box) (cadr box) - (- (caddr box) (car box)) (- (cadr (cddr box)) (cadr box)) 2 0 0) ) - ;; Routine to check if a box is zero-size - (define (box-exists? box) - (cond - ((null? box) #f) - ((= (car box) (caddr box)) #f) - ((= (cadr box) (cadddr box)) #f) - (else #t) ) ) - - (let* ((layer (car (gimp-image-get-active-layer image))) - (layer-name (car (gimp-drawable-get-name layer))) - (sel-bounds (cdr (gimp-drawable-mask-bounds layer))) - (layer-left (car (gimp-drawable-offsets layer))) - (layer-top (cadr (gimp-drawable-offsets layer))) - (layer-right (+ layer-left (car (gimp-drawable-width layer)))) - (layer-bottom (+ layer-top (car (gimp-drawable-height layer)))) - - (image-width (car (gimp-image-width image))) - (image-height (car (gimp-image-height image))) - (selection-left (+ layer-left (car sel-bounds))) - (selection-top (+ layer-top (cadr sel-bounds))) - (selection-right (+ layer-left (caddr sel-bounds))) - (selection-bottom (+ layer-top (cadddr sel-bounds))) - - (old-message-handler (car (gimp-message-get-handler))) - (offsets '()) - (boxes '()) - (float-layer 0) - (newlayers '()) - (newmade? #f) ;; In case ALL was selected nothing is done - (pos 0) - ) - - (gimp-context-push) - (gimp-image-undo-group-start image) - - (set! boxes '()) - (if (or (= (car (gimp-selection-is-empty image)) TRUE) - (zero? (car (gimp-drawable-mask-intersect layer))) ) - (begin - (gimp-message-set-handler MESSAGE-BOX) - (gimp-message "You must select part of the layer first.") - (gimp-message-set-handler old-message-handler) - ) - (begin ;; OK, we have a valid selection - (cond - ((and (= layer-left selection-left) (= layer-right selection-right)) - (set! boxes ;; Horizontal - use the top and bottom "middle" boxes - (list - (list selection-left layer-top selection-right selection-top) - (list selection-left selection-bottom selection-right layer-bottom) )) - (set! offsets - (list - '(0 0) ;; first box is always directly above original - (list 0 (- selection-top selection-bottom)) ))) - ((and (= layer-top selection-top) (= layer-bottom selection-bottom)) - (begin - (set! boxes ;; Vertical - use the left and right "middle" boxes - (list - (list layer-left selection-top selection-left selection-bottom) - (list selection-right selection-top layer-right selection-bottom) )) - (set! offsets - (list - '(0 0) ;; first box is always directly above original - (list (- selection-left selection-right) 0) )))) - (else - (set! boxes ;; Diagonal - use the four corners - (list - (list layer-left layer-top selection-left selection-top) - (list selection-right layer-top layer-right selection-top) - (list layer-left selection-bottom selection-left layer-bottom) - (list selection-right selection-bottom layer-right layer-bottom) )) - ; OFFSETS ( 0 0 ) ( selection-left-sx2 0 ) (0 sy1-sy2) ( sx1-sy2) - (set! offsets - (list - '(0 0) ;; first box is always directly above original - (list (- selection-left selection-right) 0) - (list 0 (- selection-top selection-bottom)) - (list (- selection-left selection-right) (- selection-top selection-bottom)) )))) - - (while (pair? boxes) - (when (box-exists? (car boxes)) - (set! newmade? #t) - (sel-box image (car boxes)) - (set! float-layer (car (gimp-selection-float layer (caar offsets) (cadar offsets)))) - (set! newlayers (cons float-layer newlayers)) ;; add layer to the list - (gimp-floating-sel-to-layer float-layer) ) - (set! boxes (cdr boxes)) - (set! offsets (cdr offsets)) ) - ;; New layers are generated, we just have to merge them - (unless (null? newlayers) - (set! newlayers (cdr (reverse newlayers))) ;; we don't need to merge the first new layer - ) - (while (pair? newlayers) ;; newlayers value isn't used, it just "counts" the layers - (set! float-layer (car (gimp-image-merge-down image float-layer EXPAND-AS-NECESSARY))) - (set! newlayers (cdr newlayers)) - ) - ;; Now center the new layer (relative to original) - (when newmade? - (gimp-layer-set-offsets float-layer - (+ layer-left (/ (- (car (gimp-drawable-width layer)) (car (gimp-drawable-width float-layer))) 2)) - (+ layer-top (/ (- (car (gimp-drawable-height layer)) (car (gimp-drawable-height float-layer))) 2)) ) - (while (< pos (car (gimp-image-get-layer-position image layer))) - (gimp-image-lower-layer image float-layer) - (set! pos (+ pos 1)) - ) - (gimp-image-remove-layer image layer) - (gimp-drawable-set-name float-layer layer-name) ))) - ;; reset canvas - (gimp-image-undo-group-end image) - (gimp-displays-flush) - (gimp-message-set-handler old-message-handler) - (gimp-context-pop) - ) - ) - -(script-fu-register "script-fu-sg-anti-crop" - "Anticro_p" - "Crops away the selection" - "Saul Goode" - "Saul Goode" - "1/29/2006" - "*" - SF-IMAGE "Image" 0 - SF-DRAWABLE "Drawable" 0 - ) -(script-fu-menu-register "script-fu-sg-anti-crop" - "/Layer" - ) DELETED sg-channel-blend.scm Index: sg-channel-blend.scm ================================================================== --- sg-channel-blend.scm +++ sg-channel-blend.scm @@ -1,144 +0,0 @@ -; Blending (layer) operations for channels - -; 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-channel-blend-down image channel mode opacity use-hidden?) - (set! use-hidden? (not (zero? use-hidden?))) - (let* ((channels (vector->list (cadr (gimp-image-get-channels image)))) - (base-channel #f) - (mode-lut '#( 0 1 3 15 4 5 16 17 18 19 20 21 6 7 8 9 10 )) - (channel-name (car (gimp-drawable-get-name channel))) ) - (gimp-image-undo-group-start image) - (unless (or (= (car (gimp-drawable-is-layer channel)) TRUE) - (= (car (gimp-drawable-is-layer-mask channel)) TRUE) - (not (member channel channels)) - (and (not use-hidden?) - (zero? (car (gimp-drawable-get-visible channel))) )) - (set! base-channel - (let loop ((channels (cdr (member channel channels))) - (base-channel #f) ) - (if (null? channels) - base-channel - (if (or use-hidden? (not (zero? (car (gimp-drawable-get-visible (car channels)))))) - (loop '() (car channels)) - (loop (cdr channels) base-channel) )))) - (when base-channel - (let ((orig-sel (car (gimp-selection-save image)))) - (gimp-selection-none image) - (let* ((buffer (car (gimp-edit-named-copy base-channel "Temp"))) - (tmp-image (car (gimp-edit-named-paste-as-new buffer))) - (bot-layer (car (gimp-image-get-active-layer tmp-image))) - (top-layer (car (gimp-layer-new-from-drawable channel tmp-image))) ) - (gimp-image-undo-disable tmp-image) - (gimp-drawable-set-visible bot-layer TRUE) - (gimp-drawable-set-visible bot-layer TRUE) - (gimp-image-add-layer tmp-image top-layer 0) - (gimp-drawable-set-visible top-layer TRUE) - (gimp-layer-set-opacity top-layer opacity) - (gimp-layer-set-mode top-layer (vector-ref mode-lut mode)) - (set! bot-layer (car (gimp-image-merge-down tmp-image top-layer CLIP-TO-IMAGE))) - (gimp-buffer-delete buffer) - (set! buffer (car (gimp-edit-named-copy bot-layer "Temp"))) - (gimp-image-remove-channel image channel) - (gimp-floating-sel-anchor (car (gimp-edit-named-paste base-channel buffer TRUE))) - (gimp-buffer-delete buffer) - (when (string=? "Qmask" channel-name) - (gimp-drawable-set-name base-channel "Qmask") - (gimp-drawable-set-visible base-channel TRUE) ) - (gimp-image-delete tmp-image) ) - (gimp-selection-load orig-sel) - (gimp-image-remove-channel image orig-sel) ))) - (gimp-image-undo-group-end image) - (gimp-displays-flush) - ) - ) - -(script-fu-register "script-fu-sg-channel-blend-down" - "Blend Down..." - "Blend channel with the channel beneath it." - "Saul Goode" - "Saul Goode" - "November" - "GRAY" - SF-IMAGE "Image" 0 - SF-CHANNEL "Channel" 0 - SF-OPTION "Blend Mode" '( "Normal" ; 0 - "Dissolve" ; 1 - "Multiply" ; 3 - "Divide" ; 15 - "Screen" ; 4 - "Overlay" ; 5 - "Dodge" ; 16 - "Burn" ; 17 - "Hard light" ; 18 - "Soft light" ; 19 - "Grain extract" ; 20 - "Grain merge" ; 21 - "Difference" ; 6 - "Addition" ; 7 - "Subtract" ; 8 - "Darken only (Intersect)" ; 9 - "Lighten only (Union)" ; 10 - ) - SF-ADJUSTMENT "Opacity" '( 100 0 100 1 10 0 0) - SF-TOGGLE "Use hidden channels" TRUE - ) - -(script-fu-menu-register "script-fu-sg-channel-blend-down" - "/" - ) - -(define (script-fu-sg-drawable-show-only image drawable) - (gimp-image-undo-group-start image) - (map (lambda (x) (gimp-drawable-set-visible x FALSE)) - (vector->list (cadr (gimp-image-get-layers image))) ) - (map (lambda (x) (gimp-drawable-set-visible x FALSE)) - (vector->list (cadr (gimp-image-get-channels image))) ) - (gimp-drawable-set-visible drawable TRUE) - (gimp-image-undo-group-end image) - (gimp-displays-flush) - ) - -;; Re-use layer-show-only, but with a channel -(define script-fu-sg-channel-show-only script-fu-sg-drawable-show-only) - -;; Register to Channels menu - -(script-fu-register "script-fu-sg-channel-show-only" - "Show only" - "Show only current channel." - "Saul Goode" - "Saul Goode" - "November 2011" - "GRAY" - SF-IMAGE "Image" 0 - SF-CHANNEL "Channel" 0 - ) - -(script-fu-menu-register "script-fu-sg-channel-show-only" - "/" - ) - -(script-fu-register "script-fu-sg-drawable-show-only" - "Show only" - "Show only current layer." - "Saul Goode" - "Saul Goode" - "November 2011" - "*" - SF-IMAGE "Image" 0 - SF-DRAWABLE "Drawable" 0 - ) - -(script-fu-menu-register "script-fu-sg-drawable-show-only" - "/" - ) DELETED sg-copy-mask-from-above.scm Index: sg-copy-mask-from-above.scm ================================================================== --- sg-copy-mask-from-above.scm +++ sg-copy-mask-from-above.scm @@ -1,79 +0,0 @@ -; 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. - -;; This script adds a layermask to the active layer based upon -;; the layermask of the visible layer above it in the layer stack. -;; Specifically, -;; If the active layer already has a mask, it is replaced. -;; If the above layer has a mask, it is added to the active layer. -;; If the above layer does not have a mask, a grayscale copy of the -;; above layer is added as a mask to the active layer -- unless -;; the above layer is a text layer, in which case the text -;; is used for the mask. -;; If there is no visible layer above the active one, a mask is added -;; initialized from the selection (avoiding the dialog). -; - -(define (script-fu-sg-copy-mask-from-above image layer) - (gimp-image-undo-group-start image) - (set! layer (car (gimp-image-get-active-layer image))) - (unless (= (car (gimp-layer-get-mask layer)) -1) - (gimp-image-remove-layer-mask image layer MASK-DISCARD) ) - (let ((above-layer - (let loop ((above-layer #f) - (layers (vector->list (cadr (gimp-image-get-layers image)))) ) - (if (null? layers) - above-layer - (begin - (if (= (car layers) layer) - (loop above-layer '()) - (loop (if (zero? (car (gimp-drawable-get-visible (car layers)))) - above-layer - (car layers) ) - (cdr layers) )))))) - (orig-sel (car (gimp-selection-save image))) ) - (when above-layer - (let ((above-mask (car (gimp-layer-get-mask above-layer)))) - (if (= above-mask -1) - (if (zero? (car (gimp-drawable-is-text-layer above-layer))) - (begin - (set! above-mask (car (gimp-layer-create-mask above-layer ADD-COPY-MASK))) - (gimp-layer-add-mask above-layer above-mask) - (gimp-selection-load above-mask) - (gimp-layer-remove-mask above-layer MASK-DISCARD) ) - (gimp-selection-layer-alpha above-layer) ) - (gimp-selection-load above-mask) ))) - (gimp-layer-add-mask layer (car (gimp-layer-create-mask layer ADD-SELECTION-MASK))) - (gimp-selection-load orig-sel) - (gimp-image-remove-channel image orig-sel) - (gimp-image-set-active-layer image layer) - (gimp-layer-set-edit-mask layer TRUE) - ) - (gimp-image-undo-group-end image) - (gimp-displays-flush) - ) - -(script-fu-register "script-fu-sg-copy-mask-from-above" - "Copy Layer Mask From Above" - "Copy mask from above layer a la GAP's Modify Frames" - "Saul Goode" - "saulgoode" - "February 2012" - "*" - SF-IMAGE "Image" 0 - SF-DRAWABLE "Drawable" 0 ; to allow registering in menu - ) - -(script-fu-menu-register "script-fu-sg-copy-mask-from-above" - "" - ) -(script-fu-menu-register "script-fu-sg-copy-mask-from-above" - "/Layer/Mask/Modify" - ) DELETED sg-extend-layer.scm Index: sg-extend-layer.scm ================================================================== --- sg-extend-layer.scm +++ sg-extend-layer.scm @@ -1,96 +0,0 @@ -; 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. - -; Scales the layer to match the image size. -; If a selection is present, only the area outside the bounds -; of the selection are scaled. - -(define (script-fu-sg-layer-extend-to-image-size image drawable) - (define (get-visibles image) - (let loop ((visibles '()) - (layers (vector->list (cadr (gimp-image-get-layers image)))) ) - (if (null? layers) - (if (null? visibles) '() (reverse visibles)) - (loop (if (= (car (gimp-drawable-get-visible (car layers))) 1) - (cons (car layers) visibles) - visibles ) - (cdr layers) )))) - (define (scale-to-rect layer fx1 fy1 fx2 fy2 tx1 ty1 tx2 ty2) - (let* ((floated 0) - (image (car (gimp-drawable-get-image layer))) ) - (gimp-rect-select image fx1 fy1 (- fx2 fx1) (- fy2 fy1) CHANNEL-OP-REPLACE FALSE 0) - (if (= (car (gimp-selection-is-empty image)) FALSE) - (begin - (set! floated (car (gimp-selection-float layer 0 0))) - (gimp-layer-scale floated (- tx2 tx1) (- ty2 ty1) TRUE) - (gimp-layer-set-offsets floated tx1 ty1 ) - (gimp-floating-sel-to-layer floated) - (set! layer (car (gimp-image-merge-down image floated CLIP-TO-IMAGE))) ) - layer ))) - (let* ((layer (car (gimp-image-get-active-layer image))) - (floated 0) - (bounds (cdr (gimp-drawable-mask-bounds layer))) - (width (car (gimp-image-width image))) - (height (car (gimp-image-height image))) - (lx1 (car (gimp-drawable-offsets layer))) - (ly1 (cadr (gimp-drawable-offsets layer))) - (lx2 (+ lx1 (car (gimp-drawable-width layer)))) - (ly2 (+ ly1 (car (gimp-drawable-height layer)))) - (sx1 (+ lx1 (max 1 (car bounds)))) - (sy1 (+ ly1 (max 1 (cadr bounds)))) - (sx2 (+ lx1 (min (- (car (gimp-drawable-width layer)) 1) (caddr bounds)))) - (sy2 (+ ly1 (min (- (car (gimp-drawable-height layer)) 1) (cadddr bounds)))) - (orig-sel 0) - (visibles '()) ) - (gimp-image-undo-group-start image) - (gimp-drawable-set-visible layer FALSE) - (set! visibles (get-visibles image)) - (map (lambda (x) (gimp-drawable-set-visible x FALSE)) visibles) - (gimp-drawable-set-visible layer TRUE) - (if (= (car (gimp-drawable-mask-bounds layer)) FALSE) - (set! layer (scale-to-rect layer (max lx1 0) (max ly1 0) (min lx2 width) (min ly2 height) 0 0 width height)) - (if (= (car (gimp-drawable-mask-intersect layer)) FALSE) - (begin - (gimp-layer-scale layer width height TRUE) - (gimp-layer-set-offsets layer 0 0) - ) - (begin - (set! orig-sel (car (gimp-selection-save image))) - (set! layer (scale-to-rect layer lx1 ly1 sx1 sy1 0 0 sx1 sy1 )) - (set! layer (scale-to-rect layer sx1 ly1 sx2 sy1 sx1 0 sx2 sy1 )) - (set! layer (scale-to-rect layer sx2 ly1 lx2 sy1 sx2 0 width sy1 )) - (set! layer (scale-to-rect layer sx2 sy1 lx2 sy2 sx2 sy1 width sy2 )) - (set! layer (scale-to-rect layer sx2 sy2 lx2 ly2 sx2 sy2 width height )) - (set! layer (scale-to-rect layer sx1 sy2 sx2 ly2 sx1 sy2 sx2 height )) - (set! layer (scale-to-rect layer lx1 sy2 sx1 ly2 0 sy2 sx1 height )) - (set! layer (scale-to-rect layer lx1 sy1 sx1 sy2 0 sy1 sx1 sy2 )) - (gimp-selection-load orig-sel) - (gimp-image-remove-channel image orig-sel) ))) - (map (lambda (x) (gimp-drawable-set-visible x TRUE)) visibles) - (gimp-image-set-active-layer image layer) - (gimp-image-undo-group-end image) - (gimp-displays-flush) - ) - ) - -(script-fu-register "script-fu-sg-layer-extend-to-image-size" - "Extend to Image Size" - "Scale the unselected region of the layer to the image size (does not scale selected region)" - "Saul Goode" - "Saul Goode" - "12/7/2009" - "RGB*,GRAY*" - SF-IMAGE "Image" 0 - SF-DRAWABLE "Drawable" 0 - ) -(script-fu-menu-register "script-fu-sg-layer-extend-to-image-size" - "/Layer/Resize" - ) - DELETED sg-fit-face.scm Index: sg-fit-face.scm ================================================================== --- sg-fit-face.scm +++ sg-fit-face.scm @@ -1,125 +0,0 @@ -; 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. - -;; To use this script, create path stroke consisting of two points (the -;; reference points of the source image), hold down the SHIFT key and -;; click on the location to where the first source point should be moved, -;; release the SHIFT key and click on the location to where the second -;; source point should be moved. You should have a path consisting of two -;; strokes, and each stroke should have to points. -;; -;; The active layer will be rotated, scaled, and moved such that the two -;; reference points get moved to their corresponding target points. - -(define (script-fu-sg-fit-face image drawable) - (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 ) ) ) ) ) - (let* ( - (source drawable) - (path 0) - (strokes 0) - ) - (set! path (car (gimp-image-get-active-vectors image))) - (if (= path -1) - (gimp-message "Must supply a path consisting of two strokes") - (begin - (set! strokes (gimp-vectors-get-strokes path)) - (if (<> (car strokes) 2) - (gimp-message "Must supply a path consisting of two strokes") - (let* ((orig-aspect (/ (car (gimp-drawable-width source)) (car (gimp-drawable-height source)))) - (aspect 0) - (strokes (cadr strokes)) - (src-pts (caddr (gimp-vectors-stroke-get-points path (vector-ref strokes 0)))) - (tgt-pts (caddr (gimp-vectors-stroke-get-points path (vector-ref strokes 1)))) - (sx1 (vector-ref src-pts 2)) - (sy1 (vector-ref src-pts 3)) - (sx2 (vector-ref src-pts 8)) - (sy2 (vector-ref src-pts 9)) - (tx1 (vector-ref tgt-pts 2)) - (ty1 (vector-ref tgt-pts 3)) - (tx2 (vector-ref tgt-pts 8)) - (ty2 (vector-ref tgt-pts 9)) - (src-dist (sqrt (+ (pow (- sx2 sx1) 2) (pow (- sy2 sy1) 2)))) - (tgt-dist (sqrt (+ (pow (- tx2 tx1) 2) (pow (- ty2 ty1) 2)))) - (scale-factor (/ tgt-dist src-dist)) - (src-angle (atan2 (- sy2 sy1) (- sx2 sx1) )) - (tgt-angle (atan2 (- ty2 ty1) (- tx2 tx1) )) - (angle (- src-angle tgt-angle)) - (orig-sel 0) - ) - (gimp-image-undo-group-start image) - (set! orig-sel (car (gimp-selection-save image))) - (gimp-selection-none image) - (gimp-layer-set-offsets source - (- (car (gimp-drawable-offsets source)) sx1) - (- (cadr (gimp-drawable-offsets source)) sy1) - ) - (gimp-drawable-transform-rotate source - angle - FALSE - 0 0 - TRANSFORM-BACKWARD - INTERPOLATION-CUBIC - TRUE - 3 - TRANSFORM-RESIZE-ADJUST - ) - (let* ((w (car (gimp-drawable-width source))) - (h (car (gimp-drawable-height source))) - (ar-ratio (/ orig-aspect (/ w h))) ) - (gimp-layer-resize source - (max w (* w ar-ratio)) - (max h (/ h ar-ratio)) - 0 - 0 ) ) - (gimp-layer-scale-full source - (* (car (gimp-drawable-width source)) scale-factor) - (* (car (gimp-drawable-height source)) scale-factor) - FALSE - INTERPOLATION-CUBIC - ) - (gimp-layer-set-offsets source - (+ (car (gimp-drawable-offsets source)) tx1) - (+ (cadr (gimp-drawable-offsets source)) ty1) - ) - (gimp-displays-flush) - (gimp-selection-load orig-sel) - (gimp-image-remove-channel image orig-sel) - (gimp-image-undo-group-end image) - ) - ) - ) - ) - ) - ) - -(script-fu-register "script-fu-sg-fit-face" - "Fit face to path" - "Scale, rotate, and move active layer based on active path" - "Saul Goode" - "Saul Goode" - "1/7/2010" - "*" - SF-IMAGE "Image" 0 - SF-DRAWABLE "Drawable" 0 - ) - -(script-fu-menu-register "script-fu-sg-fit-face" - "/Layer") DELETED sg-isolate.scm Index: sg-isolate.scm ================================================================== --- sg-isolate.scm +++ sg-isolate.scm @@ -1,48 +0,0 @@ -; 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. - -;; 'isolate' delete everything but the selection contents - -(define (script-fu-sg-isolate image drawable) - (gimp-image-undo-group-start image) - (gimp-context-push) - (gimp-context-set-default-colors) - (let ((orig-sel (car (gimp-selection-save image)))) - (cond - ((= (car (gimp-drawable-is-layer drawable)) TRUE) - (gimp-layer-add-alpha drawable) - (gimp-selection-invert image) - (gimp-edit-clear drawable) - (gimp-selection-load orig-sel) ) - ((or (= (car (gimp-drawable-is-channel drawable)) TRUE) - (= (car (gimp-drawable-is-layer-mask drawable)) TRUE) ) - (gimp-selection-none image) - (gimp-edit-fill drawable FOREGROUND-FILL) - (gimp-selection-load orig-sel) - (gimp-edit-fill drawable BACKGROUND-FILL) )) - (gimp-image-remove-channel image orig-sel) ) - (gimp-context-pop) - (gimp-image-undo-group-end image) - (gimp-displays-flush) - ) - -(script-fu-register "script-fu-sg-isolate" - "Isolate" - "Remove all content except the selection" - "Saul Goode" - "saulgoode" - "5/21/2007" - "*" - SF-IMAGE "Image" 0 - SF-DRAWABLE "Drawable" 0 - ) -(script-fu-menu-register "script-fu-sg-isolate" - "/Edit/Clear" - ) DELETED sg-layer-fit-in-selection.scm Index: sg-layer-fit-in-selection.scm ================================================================== --- sg-layer-fit-in-selection.scm +++ sg-layer-fit-in-selection.scm @@ -1,71 +0,0 @@ -; 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. - -; Scales the layer to match the selection size while maintaining -; original aspect ration. If no selection is present, scales -; layer to image size. Note: if the layer is floated (for example, -; after an Edit->Paste has been performed) there is no selection -; present even though there are marching ants around the originally -; selected region -- if this script is run without first making -; a new selection then the floating selection will be scaled to -; the image size. - -(define (script-fu-sg-layer-fit-in-selection image drawable) - (let* ( - (layer (car (gimp-image-get-active-layer image))) - (bounds (cdr (gimp-selection-bounds image))) - (x (car bounds)) - (y (cadr bounds)) - (width (- (caddr bounds) x)) - (height (- (cadddr bounds) y)) - (layer-width (car (gimp-drawable-width layer))) - (layer-height (car (gimp-drawable-height layer))) - (aspect (/ layer-height layer-width)) - ) - (gimp-image-undo-group-start image) - (gimp-layer-add-alpha layer) - (if (< (/ width layer-width) (/ height layer-height)) - (begin - (gimp-layer-scale-full layer - width - (* width aspect) - TRUE - INTERPOLATION-LANCZOS) - (gimp-layer-set-offsets layer x (+ y (/ (- height (* width aspect)) 2) )) - ) - (begin - (gimp-layer-scale-full layer - (/ height aspect) - height - TRUE - INTERPOLATION-LANCZOS) - (gimp-layer-set-offsets layer (+ x (/ (- width (/ height aspect)) 2)) y) - ) - ) - (gimp-image-undo-group-end image) - (gimp-displays-flush) - ) - ) - -(script-fu-register "script-fu-sg-layer-fit-in-selection" - "Fit within Selection" - "Scale the active layer so it fits in the selected region" - "Saul Goode" - "Saul Goode" - "10/25/2010" - "RGB*,GRAY*" - SF-IMAGE "Image" 0 - SF-DRAWABLE "Drawable" 0 - ) - -(script-fu-menu-register "script-fu-sg-layer-fit-in-selection" - "/Layer/Resize" - ) - DELETED sg-mirror-dup.scm Index: sg-mirror-dup.scm ================================================================== --- sg-mirror-dup.scm +++ sg-mirror-dup.scm @@ -1,120 +0,0 @@ -;; 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. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -; Revised September 2010 to work with GIMP 2.4 and later - -(define (script-fu-sg-mirror-dup image layer iterations horizontal vertical workcopy) - (let* ((work-image 0) - (new-layer 0) - (orig-width 0) - (orig-height 0) - ) - (if (= workcopy TRUE) - (begin - (set! work-image (car (gimp-image-duplicate image))) - (gimp-image-undo-disable work-image) - (gimp-display-new work-image) - ) - (begin - (set! work-image image) - (gimp-image-undo-group-start work-image) - ) - ) - (gimp-selection-none work-image) - (while (> iterations 0) - (set! layer (car (gimp-image-get-active-layer work-image))) - (if (> (car (gimp-image-get-layers work-image)) 1) - (set! layer (car (gimp-image-merge-visible-layers work-image EXPAND-AS-NECESSARY))) - ) - (if (= horizontal TRUE) - (begin - (set! new-layer (car (gimp-layer-copy layer 1))) - (gimp-image-add-layer work-image new-layer -1) - (set! orig-width (car (gimp-drawable-width new-layer))) - (set! orig-height (car (gimp-drawable-height new-layer))) - (gimp-layer-resize - new-layer - (* 2 orig-width) - orig-height - 0 - 0 - ) - (set! new-layer (car (gimp-drawable-transform-flip-simple new-layer - ORIENTATION-HORIZONTAL - TRUE - orig-width - 0)) - ) - (gimp-image-resize-to-layers work-image) - (if (> (car (gimp-image-get-layers work-image)) 1) - (set! layer (car (gimp-image-merge-visible-layers work-image EXPAND-AS-NECESSARY))) - ) - ) - ) - (if (= vertical TRUE) - (begin - (set! new-layer (car (gimp-layer-copy layer 1))) - (gimp-image-add-layer work-image new-layer -1) - (set! orig-width (car (gimp-drawable-width new-layer))) - (set! orig-height (car (gimp-drawable-height new-layer))) - (gimp-layer-resize - new-layer - orig-width - (* 2 orig-height) - 0 - 0 - ) - (set! new-layer (car (gimp-drawable-transform-flip-simple new-layer - ORIENTATION-VERTICAL - TRUE - orig-height - 0)) - ) - (gimp-image-resize-to-layers work-image) - ) - ) - (set! iterations (- iterations 1)) - ) - (gimp-selection-none work-image) - (if (> (car (gimp-image-get-layers work-image)) 1) - (set! layer (car (gimp-image-merge-visible-layers work-image EXPAND-AS-NECESSARY))) - ) - (gimp-displays-flush) - (if (= workcopy TRUE) - (begin - (gimp-image-undo-enable work-image) - (gimp-image-clean-all work-image) - ) - (gimp-image-undo-group-end image) - ) - ) - ) - -(script-fu-register "script-fu-sg-mirror-dup" - "Mirror..." - "Duplicates the image with mirror images" - "Saul Goode" - "Saul Goode" - "4/17/2006" - "*" - SF-IMAGE "Image" 0 - SF-DRAWABLE "Drawable" 0 - SF-ADJUSTMENT "Iterations (Image doubles each time)" '( 1 0 10 1 1 0 1 ) - SF-TOGGLE "Horizontal direction" TRUE - SF-TOGGLE "Vertical direction" FALSE - SF-TOGGLE "Work on copy" TRUE - ) -(script-fu-menu-register "script-fu-sg-mirror-dup" - "/Filters/Map/" - ) DELETED sg-quantize.scm Index: sg-quantize.scm ================================================================== --- sg-quantize.scm +++ sg-quantize.scm @@ -1,169 +0,0 @@ -; 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. - -; Revised January 2013 to add a "Polygonal" option that attempts -; to straighten the lines between colors. This option can be quite -; slow but yields a very nice result. - -(define (script-fu-sg-quantize orig-image drawable num-colors smoothing rounded polygonal mask-selected) - (define (polygonalize image path) - (gimp-image-undo-group-start image) - (let ((new-path (car (gimp-vectors-new image "temp")))) - (gimp-image-add-vectors image new-path -1) - (let loop ((strokes (vector->list (cadr (gimp-vectors-get-strokes path))))) - (if (null? strokes) - new-path - (let* ((stroke-info (gimp-vectors-stroke-get-points path (car strokes))) - (new-points (let point-loop ((all-points (vector->list (caddr stroke-info))) - (anchors '()) ) - (if (null? all-points) - anchors - (point-loop (cddr (cddddr all-points)) - (append anchors - (list (caddr all-points) - (cadddr all-points) - (caddr all-points) - (cadddr all-points) - (caddr all-points) - (cadddr all-points) ))))))) - (unless (< (cadr stroke-info) 18) ; must at least be a triangle - (gimp-vectors-stroke-new-from-points new-path - (car stroke-info) - (length new-points) - (list->vector new-points) - (cadddr stroke-info) )) - (loop (cdr strokes)) ))))) - - (let* ((layer 0) - (q-image 0) - (q-layer 0) - (q-sel 0) - (orig-sel 0) - (floating-sel 0) - (q-mask #f) - (buffer "") ) - (gimp-image-undo-group-start orig-image) - (set! orig-sel (car (gimp-selection-save orig-image))) - (gimp-selection-none orig-image) - (set! buffer (car (gimp-edit-named-copy drawable "temp"))) - (set! q-image (car (gimp-edit-named-paste-as-new buffer))) - (gimp-image-undo-disable q-image) - (gimp-buffer-delete buffer) - (set! q-layer (car (gimp-image-get-active-layer q-image))) - (set! buffer (car (gimp-edit-named-copy orig-sel "temp"))) - (set! q-sel (car (gimp-selection-save q-image))) - (set! floating-sel (car (gimp-edit-named-paste q-sel buffer FALSE))) - (gimp-buffer-delete buffer) - (gimp-floating-sel-anchor floating-sel) - (unless (zero? (car (gimp-drawable-has-alpha q-layer))) - (set! q-mask (car (gimp-layer-create-mask q-layer ADD-ALPHA-TRANSFER-MASK))) - (gimp-layer-add-mask q-layer q-mask) ) - (unless (zero? mask-selected) - (gimp-selection-load q-sel) - (gimp-selection-invert q-image) ) - (if (zero? rounded) - (begin - (unless (zero? smoothing) - (plug-in-gauss RUN-NONINTERACTIVE q-image q-layer smoothing smoothing 0) ) - (gimp-image-convert-indexed q-image NO-DITHER MAKE-PALETTE num-colors FALSE FALSE "") - ) - (begin - (gimp-image-convert-indexed q-image NO-DITHER MAKE-PALETTE num-colors FALSE FALSE "") - (gimp-image-convert-rgb q-image) - (unless (zero? smoothing) - (plug-in-gauss RUN-NONINTERACTIVE q-image q-layer smoothing smoothing 0) ) - (gimp-image-convert-indexed q-image NO-DITHER MAKE-PALETTE num-colors FALSE FALSE "") - )) - (let ((colors (vector->list (cadr (gimp-image-get-colormap q-image))))) - (gimp-image-convert-rgb q-image) - (gimp-selection-none q-image) - (unless (zero? polygonal) - (gimp-context-push) - (let ((new-layer (car (gimp-layer-new q-image - (car (gimp-drawable-width q-layer)) - (car (gimp-drawable-height q-layer)) - RGBA-IMAGE - "Fill" - 100 - NORMAL-MODE )))) - (gimp-drawable-fill new-layer TRANSPARENT-FILL) - (gimp-image-add-layer q-image new-layer -1) - (let ((prog-max (length colors))) - (let colors-loop ((colors colors) - (prog-current 0) ) - (unless (null? colors) - (gimp-context-set-foreground (list (car colors) (cadr colors) (caddr colors))) - (gimp-image-select-color q-image CHANNEL-OP-REPLACE q-layer (list (car colors) - (cadr colors) - (caddr colors) )) - (plug-in-sel2path 1 q-image q-layer) - (gimp-progress-set-text "Converting to paths") - (gimp-progress-update (/ prog-current prog-max)) - (gimp-image-select-item q-image - CHANNEL-OP-REPLACE - (polygonalize q-image (car (gimp-image-get-active-vectors q-image))) ) - (gimp-edit-fill new-layer FOREGROUND-FILL) - (colors-loop (cdddr colors) (+ prog-current 3)) ))) - (gimp-progress-set-text "Filling gaps") - (gimp-selection-none q-image) - (while (< (car (gimp-histogram new-layer HISTOGRAM-ALPHA 0 255)) 255.0) - (plug-in-vpropagate RUN-NONINTERACTIVE - q-image - new-layer - 6 ; more opaque - 3 ; with alpha - 1.0 ; maximum amount - 15 ; all directions - 0 - 255 )) - (when q-mask - (gimp-selection-load (car (gimp-layer-get-mask q-layer))) - (gimp-layer-add-mask new-layer (car (gimp-layer-create-mask new-layer ADD-SELECTION-MASK))) - (gimp-selection-none q-image) ) - (gimp-image-remove-layer q-image q-layer) - (set! q-layer new-layer) ) - (gimp-context-pop) )) - (when q-mask - (gimp-layer-remove-mask q-layer MASK-APPLY) ) - (set! buffer (car (gimp-edit-named-copy q-layer "temp"))) - (set! floating-sel (car (gimp-edit-named-paste drawable buffer TRUE))) - (when (zero? mask-selected) - (gimp-selection-load orig-sel) ) - (gimp-floating-sel-anchor floating-sel) - (gimp-image-undo-enable q-image) - (gimp-image-delete q-image) - (gimp-selection-load orig-sel) - (gimp-image-remove-channel orig-image orig-sel) - (gimp-buffer-delete buffer) - (gimp-progress-end) - (gimp-image-undo-group-end orig-image) - (gimp-displays-flush) - ) - ) - -(script-fu-register "script-fu-sg-quantize" - "Quantize..." - "Quantize layer to a specified number of colors" - "Saul Goode" - "Saul Goode" - "May 2011" - "RGB*, GRAY*" - SF-IMAGE "Image" 0 - SF-DRAWABLE "Layer" 0 - SF-ADJUSTMENT "Number of colors" '(16 2 256 1 10 0 0) - SF-ADJUSTMENT "Smoothing" '(0 0 200 1 10 0 0) - SF-TOGGLE "Rounded?" TRUE - SF-TOGGLE "Polygonal? (slow)" FALSE - SF-TOGGLE "Use selection as smoothing mask" FALSE - ) - -(script-fu-menu-register "script-fu-sg-quantize" - "/Colors" - ) DELETED sg-scale-to-selection.scm Index: sg-scale-to-selection.scm ================================================================== --- sg-scale-to-selection.scm +++ sg-scale-to-selection.scm @@ -1,54 +0,0 @@ -; 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. - -; Scales the layer to match the selection size. -; If no selection is present, scales layer to image size -; Note: if the layer is floated there is no selection present -; even though there are marching ants around the originally -; selected region -- if this script is run without first making -; a new selection then the floating selection will be scaled to -; the image size. - -(define (sg-layer-scale-to-selection image drawable) - (let* ( - (layer (car (gimp-image-get-active-layer image))) - (bounds (gimp-selection-bounds image)) - (x 0) - (y 0) - (width (car (gimp-image-width image))) - (height (car (gimp-image-height image))) - ) - (when (= (car bounds) TRUE) - (set! x (cadr bounds)) - (set! y (caddr bounds)) - (set! width (- (cadddr bounds) x)) - (set! height (- (car (cddddr bounds)) y))) - (gimp-image-undo-group-start image) - (gimp-layer-scale layer width height TRUE) - (gimp-layer-set-offsets layer x y) - (gimp-image-undo-group-end image) - (gimp-displays-flush) - ) - ) - -(script-fu-register "sg-layer-scale-to-selection" - "Scale to Selection" - "Scale the active layer and fit it in the selection (rectangular)" - "Saul Goode" - "Saul Goode" - "1/3/2010" - "*" - SF-IMAGE "Image" 0 - SF-DRAWABLE "Drawable" 0 - ) -(script-fu-menu-register "sg-layer-scale-to-selection" - "/Layer/Resize" - ) - DELETED sg-tooninator.scm Index: sg-tooninator.scm ================================================================== --- sg-tooninator.scm +++ sg-tooninator.scm @@ -1,67 +0,0 @@ -; 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-tooninator image drawable) - (unless (zero? (car (gimp-drawable-is-layer drawable))) - (gimp-image-undo-group-start image) - (let ((gray-mode? (= (car (gimp-image-base-type image)) 1)) - (retinex-layer 0) - (edge-layer 0) ) - (if gray-mode? - (gimp-image-convert-rgb image) ) - (set! retinex-layer (car (gimp-layer-copy drawable TRUE))) - (gimp-drawable-set-name retinex-layer "Retinex") - (gimp-image-add-layer image retinex-layer -1) - (plug-in-retinex RUN-NONINTERACTIVE image retinex-layer 16 3 0 0.1) - (gimp-image-set-active-layer image retinex-layer) - (gimp-layer-set-mode retinex-layer VALUE-MODE) - (set! edge-layer (car (gimp-layer-copy drawable TRUE))) - (gimp-drawable-set-name edge-layer "Edges") - (gimp-image-add-layer image edge-layer -1) - (let ((retinex-mask (car (gimp-layer-create-mask retinex-layer 0))) - (buffer (car (gimp-edit-named-copy drawable "orig"))) ) - (gimp-layer-add-mask retinex-layer retinex-mask) - (gimp-floating-sel-anchor (car (gimp-edit-named-paste retinex-mask buffer TRUE))) - (gimp-threshold retinex-mask 36 255) ) - (let ((temp-layer (car (gimp-layer-copy retinex-layer TRUE)))) - (gimp-image-set-active-layer image edge-layer) - (gimp-image-add-layer image temp-layer -1) - (set! edge-layer (car (gimp-image-merge-down image temp-layer EXPAND-AS-NECESSARY))) ) - (plug-in-gauss RUN-NONINTERACTIVE image edge-layer 2.0 2.0 0) - (plug-in-gauss RUN-NONINTERACTIVE image edge-layer 2.0 2.0 0) - (plug-in-laplace RUN-NONINTERACTIVE image edge-layer) - (plug-in-despeckle RUN-NONINTERACTIVE image edge-layer 1 1 0 255) - (when (zero? (car (gimp-selection-is-empty image))) - (gimp-selection-invert image) - (gimp-edit-clear edge-layer) - (gimp-edit-clear retinex-layer) - (gimp-selection-invert image) ) - (if gray-mode? - (gimp-image-convert-grayscale image) )) - (gimp-image-undo-group-end image) ) - (gimp-displays-flush) - ) - -(script-fu-register "script-fu-sg-tooninator" - "Toon-inator" - "Create two adjuvant layers which result in a cartoon-like appearance" - "Saul Goode" - "Saul Goode" - "Sept 2011" - "RGB*,GRAY*" - SF-IMAGE "Image" 0 - SF-DRAWABLE "Layer" 0 - ) - -(script-fu-menu-register "script-fu-sg-tooninator" - "/Filters/Artistic/" - ) - - Index: sg-viktoria.scm ================================================================== --- sg-viktoria.scm +++ sg-viktoria.scm @@ -1,6 +1,31 @@ +; 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-viktoria orig-image orig-drawable) + (define v-grid '( 65 140 215 265 315 365 415 465 515 565 615 + 665 715 765 815 865 915 965 1015 1065 1115 1165 1215 )) + (define h-grid '(070 105 140 175 210 245 280 315 350 385 420 455 490 525 + 560 595 630 665 700 735 770 805 840 875 910 945 980 )) + ; Splits a list at k'th element + ; Returns a pair of lists ((prefix) . (suffix)) + (define (split lis k) + (let loop ((suffix lis) + (prefix '()) + (k (min k (length lis))) ) + (if (zero? k) + (cons (reverse prefix) suffix) + (loop (cdr suffix) + (cons (car suffix) prefix) + (pred k) )))) (define (row-solid? image drawable y) (let ((color (vector->list (cadr (gimp-drawable-get-pixel drawable 0 y)))) (width (car (gimp-image-width image))) ) (gimp-rect-select image 0 y width 1 CHANNEL-OP-REPLACE 0 0) (gimp-by-color-select drawable @@ -21,47 +46,90 @@ 1 CHANNEL-OP-SUBTRACT FALSE FALSE 0 - 0 ) ) + 0 )) (not (zero? (car (gimp-selection-is-empty image)))) ) - (define (create-table-image) + + (define (place-text layer text x-list y-list) + (let ((image (car (gimp-drawable-get-image layer))) + (text-width (car (gimp-text-get-extents-fontname text + 20 + PIXELS + "Sans Bold" ))) ) + (gimp-floating-sel-anchor + (car (gimp-text-fontname image + layer + (+ (car x-list) + (/ (- (cadr x-list) + (car x-list) ) + 2 ) + (- (/ text-width 2)) ) + (+ (car y-list) 6) + text + 0 + TRUE + 20 + PIXELS + "Sans Bold" ))))) + + (define (create-table-image page-num) (let* ((table-image (car (gimp-image-new 1280 1024 RGB))) (table-layer (car (gimp-layer-new table-image 1280 1024 RGB-IMAGE "Table" 100 NORMAL-MODE))) - (v-grid '( 65 140 215 265 315 365 415 465 515 - 565 615 665 715 765 815 865 915 965 1015 - 1065 1115 1165 1215 )) - (h-grid '(105 140 175 210 245 280 315 350 385 420 - 455 490 525 560 595 630 665 700 735 770 - 805 840 875 910 945 )) (brush (car (gimp-brush-new "temp-brush"))) - ) + (page-string (string-append "Page " + (number->string page-num) ))) (gimp-image-undo-disable table-image) (gimp-image-add-layer table-image table-layer 0) (gimp-drawable-fill table-layer WHITE-FILL) (gimp-context-push) (gimp-context-set-foreground '(0 0 0)) + + (gimp-floating-sel-anchor + (car (gimp-text-fontname table-image + table-layer + (- (car (gimp-image-width table-image)) + (car (gimp-text-get-extents-fontname page-string + 24 + PIXELS + "Sans Bold" )) + 65 ) + 25 + page-string + 0 + TRUE + 20 + PIXELS + "Sans Bold" ))) + (gimp-brush-set-radius brush 1) (gimp-context-set-paint-method "gimp-paintbrush") (gimp-context-set-brush brush) (gimp-context-set-paint-mode NORMAL-MODE) + (gimp-progress-pulse) + (gimp-progress-set-text (string-append "Creating " + page-string + "..." )) (let loop ((v-lines v-grid)) ; paint horizontal lines + (gimp-progress-pulse) (unless (null? v-lines) (gimp-paintbrush table-layer 0 4 (vector (car v-lines) (car h-grid) (car v-lines) (car (last h-grid))) PAINT-CONSTANT 0 ) (loop (cdr v-lines)) )) (let loop ((h-lines h-grid)) ; paint vertical lines + (gimp-progress-pulse) (unless (null? h-lines) (gimp-paintbrush table-layer 0 4 (vector (car v-grid) (car h-lines) (car (last v-grid)) (car h-lines)) PAINT-CONSTANT 0 ) (loop (cdr h-lines)) )) (let loop-cols ((xs (cdddr v-grid))) ; select grayed cells + (gimp-progress-pulse) (unless (null? xs) (let loop-rows ((ys (butlast h-grid)) ) (if (null? ys) (loop-cols (cddr xs)) (begin @@ -75,60 +143,32 @@ (gimp-edit-fill table-layer FOREGROUND-FILL) (gimp-selection-none table-image) (gimp-brush-delete brush) (gimp-context-set-foreground '(0 0 0)) - (gimp-floating-sel-anchor - (car (gimp-text-fontname table-image - table-layer - (+ (car v-grid) 9) - (+ (car h-grid) 6) - "ROW" - 0 - TRUE - 20 - PIXELS - "Sans Bold" ))) - (gimp-floating-sel-anchor - (car (gimp-text-fontname table-image - table-layer - (+ (cadr v-grid) 6) - (+ (car h-grid) 6) - "READ" - 0 - TRUE - 20 - PIXELS - "Sans Bold" ))) - (let loop ((xs (cddr (butlast v-grid))) + (place-text table-layer "ROW" v-grid h-grid) + (place-text table-layer "READ" (cdr v-grid) h-grid) + (let loop ((xs (cddr v-grid)) (text? #f) ) - (unless (null? xs) - (gimp-floating-sel-anchor - (car (gimp-text-fontname table-image - table-layer - (+ (car xs) 16) - (+ (car h-grid) 6) - (if text? - "S" - "O" ) - 0 - TRUE - 20 - PIXELS - "Sans Bold" ))) + (gimp-progress-pulse) + (unless (null? (cdr xs)) + (place-text table-layer (if text? "S" "O") xs h-grid) (loop (cdr xs) (not text?) ))) (gimp-context-pop) table-image ) ) + ; MAIN processing starts here + (gimp-context-push) (let* ((width (car (gimp-drawable-width orig-drawable))) (height (car (gimp-drawable-height orig-drawable))) (buffer (car (gimp-edit-named-copy orig-drawable "BG"))) (image (car (gimp-edit-named-paste-as-new buffer))) (layer (car (gimp-image-flatten image))) ) + (gimp-buffer-delete buffer) (unless (zero? (car (gimp-image-base-type image))) (gimp-image-convert-rgb image) ) (gimp-image-convert-indexed image NO-DITHER MAKE-PALETTE @@ -138,12 +178,15 @@ "") (gimp-image-convert-rgb image) (plug-in-autocrop RUN-NONINTERACTIVE image layer) (set! width (car (gimp-image-width image))) (set! height (car (gimp-image-height image))) + (gimp-progress-pulse) + (gimp-progress-set-text "Scanning...") (let ((rows (let loop ((y 0) (rows '()) ) + (gimp-progress-pulse) (while (and (< y height) (row-solid? image layer y) ) (set! y (succ y)) ) (let ((start-row y)) (while (and (< y height) (not (row-solid? image layer y)) ) (set! y (succ y)) ) @@ -151,10 +194,11 @@ (reverse rows) (loop (succ y) (cons (cons start-row y) rows) )))))) (let ((cols (let loop ((x 0) (cols '()) ) + (gimp-progress-pulse) (while (and (< x width) (col-solid? image layer x) ) (set! x (succ x)) ) (let ((start-col x)) (while (and (< x width) (not (col-solid? image layer x)) ) (set! x (succ x)) ) @@ -162,10 +206,11 @@ (reverse cols) (loop (succ x) (cons (cons start-col x) cols) )))))) (set! rows (map (lambda (x) (/ (+ (car x) (cdr x)) 2)) rows)) (set! cols (map (lambda (x) (/ (+ (car x) (cdr x)) 2)) cols)) + (gimp-selection-none image) (gimp-threshold layer 127 255) (gimp-image-convert-grayscale image) (set! rows (let loop-rows ((rows rows) (row-result '()) ) @@ -180,82 +225,138 @@ (if rest (rle rest (cons (cons (car cols) (- (length cols) (length rest))) result) ) (loop-rows (cdr rows) (cons (cons (cons (car cols) (length cols)) result) row-result) )))))))) + ; Our tables need to be filled from bottom of the scanned image to its top + (set! rows (reverse rows)) + ; Now we need to reverse direction for every other row (set! rows (let loop ((rows rows) (result '()) - (rvs? #t) ) + (rvs? #f) ) (if (null? rows) (reverse result) (loop (cdr rows) (cons (if rvs? (reverse (car rows)) (car rows) ) result ) (not rvs?) )))) ; At this point we have a list of row information, ready to create our table + (gimp-image-delete image) + ; Next we need to ensure that each row starts with an OPEN run (possibly of zero length) + (set! rows + (let loop ((rows rows) + (result '()) ) + (if (null? rows) + (reverse result) + (if (caaar rows) + (loop (cdr rows) + (cons (cons 0 (map cdr (car rows))) result) ) + (loop (cdr rows) + (cons (map cdr (car rows)) result) ))))) + ; Next we prepend a row number to each row and insure each line + ; has no more than 20 cells. + (set! rows + (let loop ((rows rows) + (row-num 1) + (continued? #f) + (result '()) ) + (if (pair? rows) + (let ((remaining (cdr (split (car rows) 20))) + (this-row (car (split (car rows) 20))) ) + (if (pair? remaining) + (loop (cons remaining (cdr rows)) + row-num + #t + (append result (list (cons (if continued? + "---" + (number->string row-num) ) + this-row))) ) + (loop (cdr rows) + (succ row-num) + #f + (append result (list (cons (if continued? + "---" + (number->string row-num) ) + this-row))) ))) + result ))) (gimp-context-set-foreground '(0 0 0)) - (while (pair? rows) - (let* ((table-image (create-table-image)) - (table-layer (car (gimp-image-get-active-layer table-image))) - (v-grid '( 65 140 215 265 315 365 415 465 515 - 565 615 665 715 765 815 865 915 965 1015 - 1065 1115 1165 )) - (h-grid '(140 175 210 245 280 315 350 385 420 - 455 490 525 560 595 630 665 700 735 770 - 805 840 875 910 )) - row-num 1 ) - (let loop ((cell-rows rows) - (line-num (length h-grid)) - (left-to-right? #f) ) - (unless? (or (null? row-cells) (zero? line-num)) - (let ((text-width (car (gimp-text-get-extents-fontname (number->string row-num) - 20 - PIXELS - "Sans Bold" )))) - (gimp-floating-sel-anchor ; row number - (car (gimp-text-fontname table-image - table-layer - (+ (car v-grid) - (/ (- (cadr v-grid) - (car v-grid) ) - 2 ) - (- (/ text-width 2)) ) - (+ (car h-grid) 6) - (number->string row-num) - 0 - TRUE - 20 - PIXELS - "Sans Bold" )))) - (gimp-floating-sel-anchor ; read direction - (car (gimp-text-fontname table-image - table-layer - (+ (cadr v-grid) ) - (+ (car h-grid) 6) - (if left-to-right? - "L" - "R" ) - 0 - TRUE - 20 - PIXELS - "Sans Bold" ))) - (let ((cell-row (if left-to-right? - (car cell-rows) - (reverse (car cell-rows)) ))) - (if (caar cell-row) - (set! cell-row (cons '(#f . 0) cell-row))) - (let cell-loop ((cells cell-row) - (cell-cols (cddr v-grid)) ; skip the 'row' and 'read' columns - (cell-cnt 20) ) - (when (zero? cell-cnt) - (set! cell-cnt 20) - (set! line-num (pred line-num)) - - - - ) - (if null? cells) - - + (let ((h-grid (cdr h-grid))) + (let ((images + (let page-loop ((page-rows (car (split rows 25))) + (remaining-rows (cdr (split rows 25))) + (page-num 1) + (row-grid h-grid) + (tables '()) ) + (if (null? page-rows) + (if (null? remaining-rows) + tables ; Done! + (page-loop (car (split remaining-rows 25)) + (cdr (split remaining-rows 25)) + page-num + h-grid + tables )) + (begin + (let* ((table-image (create-table-image page-num)) + (table-layer (car (gimp-image-get-active-layer table-image))) ) + (gimp-progress-pulse) + (gimp-progress-set-text "Filling table...") + (set! tables (cons table-image tables)) + (let line-loop ((line-rows page-rows) + (row-offsets h-grid) + (line-cnt (length page-rows)) ) + (unless (or (null? line-rows) (zero? line-cnt)) + (place-text table-layer (caar line-rows) v-grid row-offsets) + (let ((num-text (caar line-rows))) + (place-text table-layer num-text v-grid row-offsets) + (place-text table-layer + (if (string=? num-text "---") + "-" + (if (even? (string->number num-text)) + "L" + "R" )) + (cdr v-grid) + row-offsets )) + (let cell-loop ((cells (cdar line-rows)) + (col-grid (cddr v-grid)) ; skip the 'row' and 'read' columns + (cell-cnt 20) ) + (gimp-progress-pulse) + (unless (or (zero? cell-cnt) + (null? cells) ) + (place-text table-layer (number->string (car cells)) col-grid row-offsets) + (cell-loop (cdr cells) + (cdr col-grid) + (pred cell-cnt) ))) + (line-loop (cdr line-rows) + (cdr row-offsets) + (pred line-cnt) )))) + (page-loop '() + remaining-rows + (succ page-num) + h-grid + tables )))))) + (let loop ((images images)) + (unless (null? images) + (gimp-image-undo-enable (car images)) + (gimp-display-new (car images)) + (loop (cdr images)) )) + )))) + (gimp-displays-flush) + (gimp-progress-end) + ) + (gimp-context-pop) + ) + +(script-fu-register "script-fu-sg-viktoria" + "_Crochet Pattern by Viktoria" + "Create crochet instructions per Viktoria" + "Saul Goode" + "Saul Goode" + "April 2013" + "*" + SF-IMAGE "Image" 0 + SF-DRAWABLE "Drawable" 0 + ) +(script-fu-menu-register "script-fu-sg-viktoria" + "/File/Create" + ) DELETED sg-warptext.scm Index: sg-warptext.scm ================================================================== --- sg-warptext.scm +++ sg-warptext.scm @@ -1,549 +0,0 @@ -; warptext.scm - a Script-fu for warping text to fill a region defined by -; a four-point bezier path -; -; 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. -; -; The GNU Public License is available at -; http://www.gnu.org/copyleft/gpl.html -; - -; Transform the supplied stroke using the transformation matrix (m). -; The original stroke is removed from the path and "replaced" by the -; newly created transformed stroke. -; Returns the ID of the newly created stroke. -; -(define (warptext-transform-stroke m path stroke) - (let* ((stroke-info (gimp-vectors-stroke-get-points path stroke)) - (type (car stroke-info)) - (v-length (cadr stroke-info)) - (points (vector->list (caddr stroke-info))) - (closed?* (cadddr stroke-info)) - (trans-points nil) - (coords nil) - ) - (while (pair? points) - (set! coords (transform-point m (car points) (cadr points))) - (set! trans-points (cons (cadr coords) - (cons (car coords) - trans-points))) - (set! points (cddr points)) - ) - (set! points (list->vector (reverse trans-points))) - (gimp-vectors-remove-stroke path stroke) - (gimp-vectors-stroke-new-from-points path type v-length points closed?*) - ) - ) - -; Transform all strokes within a path. Original strokes are deleted and -; replaced by transformed substitutes. -; -(define (warptext-transform-path m path) - (let loop ((strokes (vector->list (cadr (gimp-vectors-get-strokes path))))) - (if (null? strokes) - path - (begin - (warptext-transform-stroke m path (car strokes)) - (loop (cdr strokes)))) - ) - ) - -; Transforms a 4-point envelope path such that the four control points -; are repositioned over the four corners of a rectangle that circumscribes -; the supplied 'text-path' (text-path does not actually have to represent -; text). THE IMAGE CANVAS IS RESIZED to fit the circumscribed rectangle -; to facillitate subsequent normalization of the text path (the original -; image canvas must eventually be restored). NOTE: the original envelope -; stroke is deleted, replaced by a new transformed stroke (in the same -; envelope path). -; -; Returns a list containing the correction transformation matrix and a -; list containing information needed to restore the original canvas -; (using 'gimp-image-resize'). -; -(define (warptext-square-off-envelope image text-path env-path env-stroke padding) - (let* ((points #()) - (trans-points nil) - (width (car (gimp-image-width image))) - (height (car (gimp-image-height image))) - (layer (car (gimp-layer-new image - width - height - (+ (* (car (gimp-image-base-type image)) 2) 1) - "resize" - 100 - NORMAL-MODE))) - (x 0) - (y 0) - (w 0) - (h 0) - (m (mat3-identity)) - (brush (car (gimp-brush-new "temp-brush"))) - ) - (gimp-image-add-layer image layer 0) - (gimp-drawable-fill layer WHITE-FILL) - (gimp-context-set-foreground '(0 0 0)) - (gimp-brush-set-radius brush 1) - (gimp-context-set-paint-method "gimp-paintbrush") - (gimp-context-set-brush brush) - (gimp-context-set-paint-mode NORMAL-MODE) - (gimp-selection-none image) - (gimp-edit-stroke-vectors layer text-path) - (gimp-brush-delete brush) - (plug-in-autocrop-layer RUN-NONINTERACTIVE image layer) - (gimp-layer-resize layer - (+ (car (gimp-drawable-width layer)) - (* 2 padding)) - (+ (car (gimp-drawable-height layer)) - (* 2 padding)) - padding - padding) - (set! x (car (gimp-drawable-offsets layer))) - (set! y (cadr (gimp-drawable-offsets layer))) - (set! w (car (gimp-drawable-width layer))) - (set! h (car (gimp-drawable-height layer))) - (gimp-image-resize image w h (- x) (- y)) - (set! points (caddr (gimp-vectors-stroke-get-points env-path env-stroke))) - (set! m (mat3-perspective m 0 0 w h - (vector-ref points 2) - (vector-ref points 3) - (vector-ref points 8) - (vector-ref points 9) - (vector-ref points 20) - (vector-ref points 21) - (vector-ref points 14) - (vector-ref points 15))) - (warptext-transform-stroke (mat3-invert m) env-path env-stroke) - (gimp-image-remove-layer image layer) - ; return the matrix, and info to restore original image bounds - (list m (list width height x y)) - ) - ) - -; Normalize all of the control points in all of the strokes so that -; they can be used as alpha interpolations on the bezier surface. -; -; Assuming that 'warptext-square-off-envelope' has been run prior to this, -; width and height stem from the image dimensions. -; Warning: Text path is modified by this procedure! -; -(define (warptext-normalize-text-path path width height) - (let ((m (mat3-scale (mat3-identity) (/ width) (/ height)))) - (let loop ((strokes (vector->list (cadr (gimp-vectors-get-strokes path))))) - (if (null? strokes) - (vector->list (cadr (gimp-vectors-get-strokes path))) - (begin - (warptext-transform-stroke m path (car strokes)) - (loop (cdr strokes))))) - ) - ) - -; Map the control points of the text path to the bezier surface described -; by the envelope path. The text path should be normalized and the envelope -; path should be "squared-off". -; Returns ID of generated warped path. - -(define (warptext-map-bezier-envelope image text-path env-path quality) - - (define (make-latitude-stroke curve-path curve-top curve-bot alpha) - (let - loop ((top (vector->list (caddr (gimp-vectors-stroke-get-points curve-path curve-top)))) - (bot (vector->list (caddr (gimp-vectors-stroke-get-points curve-path curve-bot)))) - (lat-curve ())) - (if (null? top) - (car (gimp-vectors-stroke-new-from-points curve-path - 0 - 12 - (list->vector (reverse lat-curve)) - 0)) - (loop (cddr top) - (cddr bot) - (cons (+ (* (- 1 alpha) (cadr top)) (* alpha (cadr bot))) - (cons (+ (* (- 1 alpha) (car top)) (* alpha (car bot))) - lat-curve)))))) - - (define (reposition-ends curve-path curve-left curve-right length-left length-right lat-stroke alpha) - (let* ( - (lat-points (caddr (gimp-vectors-stroke-get-points curve-path lat-stroke))) - (left (gimp-vectors-stroke-get-point-at-dist curve-path - curve-left - (* alpha length-left) - 1)) - (leftx (car left)) - (lefty (cadr left)) - (right (gimp-vectors-stroke-get-point-at-dist curve-path - curve-right - (* alpha length-right) - 1)) - (rightx (car right)) - (righty (cadr right)) - (left-dx (- leftx (vector-ref lat-points 2))) - (left-dy (- lefty (vector-ref lat-points 3))) - (right-dx (- rightx (vector-ref lat-points 8))) - (right-dy (- righty (vector-ref lat-points 9))) - ) - (gimp-vectors-remove-stroke curve-path lat-stroke) - (car (gimp-vectors-stroke-new-from-points - curve-path - 0 - 12 - (vector - leftx ;; outer control handles don't matter - lefty - leftx ;; (+ (vector-ref lat-points 2) left-dx) - lefty ;; (+ (vector-ref lat-points 3) left-dy) - (+ (vector-ref lat-points 4) left-dx) - (+ (vector-ref lat-points 5) left-dy) - (+ (vector-ref lat-points 6) right-dx) - (+ (vector-ref lat-points 7) right-dy) - rightx ;; (+ (vector-ref lat-points 8) right-dx) - righty ;; (+ (vector-ref lat-points 9) right-dy) - rightx ;; outer handles don't matter - righty) - FALSE)))) - - - - (let* ((warped-path (car (gimp-vectors-new image "warped"))) - (env-stroke (vector-ref (cadr (gimp-vectors-get-strokes env-path)) 0)) - (env-coords (caddr (gimp-vectors-stroke-get-points env-path env-stroke))) - (curve-path (car (gimp-vectors-new image "curve"))) - (curve-top (car (gimp-vectors-stroke-new-from-points - curve-path - 0 - 12 - (vector - (vector-ref env-coords 0) - (vector-ref env-coords 1) - (vector-ref env-coords 2) - (vector-ref env-coords 3) - (vector-ref env-coords 4) - (vector-ref env-coords 5) - (vector-ref env-coords 6) - (vector-ref env-coords 7) - (vector-ref env-coords 8) - (vector-ref env-coords 9) - (vector-ref env-coords 10) - (vector-ref env-coords 11)) - FALSE))) - (curve-right (car (gimp-vectors-stroke-new-from-points - curve-path - 0 - 12 - (vector - (vector-ref env-coords 6) - (vector-ref env-coords 7) - (vector-ref env-coords 8) - (vector-ref env-coords 9) - (vector-ref env-coords 10) - (vector-ref env-coords 11) - (vector-ref env-coords 12) - (vector-ref env-coords 13) - (vector-ref env-coords 14) - (vector-ref env-coords 15) - (vector-ref env-coords 16) - (vector-ref env-coords 17)) - FALSE))) - (curve-bot (car (gimp-vectors-stroke-new-from-points - curve-path - 0 - 12 - (vector - (vector-ref env-coords 22) - (vector-ref env-coords 23) - (vector-ref env-coords 20) - (vector-ref env-coords 21) - (vector-ref env-coords 18) - (vector-ref env-coords 19) - (vector-ref env-coords 16) - (vector-ref env-coords 17) - (vector-ref env-coords 14) - (vector-ref env-coords 15) - (vector-ref env-coords 12) - (vector-ref env-coords 13)) - FALSE))) - (curve-left (car (gimp-vectors-stroke-new-from-points - curve-path - 0 - 12 - (vector - (vector-ref env-coords 4) - (vector-ref env-coords 5) - (vector-ref env-coords 2) - (vector-ref env-coords 3) - (vector-ref env-coords 0) - (vector-ref env-coords 1) - (vector-ref env-coords 22) - (vector-ref env-coords 23) - (vector-ref env-coords 20) - (vector-ref env-coords 21) - (vector-ref env-coords 18) - (vector-ref env-coords 19)) - FALSE))) - (text-strokes (vector->list (cadr (gimp-vectors-get-strokes text-path)))) - (type 0) - (points nil) - (interpolated-points nil) - (v-length 0) - (closed FALSE) - (coords nil) - (alpha-y 0) - (trans-points nil) - (length-left (car (gimp-vectors-stroke-get-length curve-path curve-left 0.5))) - (length-right (car (gimp-vectors-stroke-get-length curve-path curve-right 0.5))) - (lat-stroke 0) - (stroke-info nil) - ) - (gimp-image-add-vectors image curve-path 0) - (gimp-vectors-set-visible curve-path TRUE) - (gimp-image-add-vectors image warped-path 0) - (gimp-vectors-set-visible warped-path TRUE) - (while (pair? text-strokes) - (set! stroke-info (gimp-vectors-stroke-get-points text-path (car text-strokes))) - (set! type (car stroke-info)) - (set! closed (cadddr stroke-info)) - (set! interpolated-points (gimp-vectors-stroke-interpolate text-path - (car text-strokes) - (/ 0.5 quality))) - (set! closed (caddr interpolated-points)) - (let - loop ((points (vector->list (cadr interpolated-points))) - (trans-points nil)) - (if (null? points) - (begin - (set! trans-points (reverse trans-points)) - (gimp-vectors-stroke-new-from-points warped-path - type - (length trans-points) - (list->vector trans-points) - closed)) - (begin - (set! lat-stroke (make-latitude-stroke curve-path - curve-top - curve-bot - (cadr points))) - (set! lat-stroke (reposition-ends curve-path - curve-left - curve-right - length-left - length-right - lat-stroke - (cadr points))) - (set! coords (gimp-vectors-stroke-get-point-at-dist - curve-path - lat-stroke - (* (car (gimp-vectors-stroke-get-length curve-path lat-stroke 0.5)) - (car points)) - 0.5)) - (gimp-vectors-remove-stroke curve-path lat-stroke) - (loop (cddr points) (cons (cadr coords) - (cons (car coords) - (cons (cadr coords) - (cons (car coords) - (cons (cadr coords) - (cons (car coords) - trans-points)))))))))) - (set! text-strokes (cdr text-strokes))) - (gimp-image-remove-vectors image curve-path) - warped-path - ) - ) - -; A 'mat3' is a "3x3 list matrix" corresponding to a C-style matrix[y][x] -; Accessing an element is performed with (cXr (cYr matrix)) where -; (cYr m) specifies a particular row in the matrix: car=1st, cadr=2nd, caddr=3rd -; (map cXr m) specifies a particular column: car=1st, cadr=2nd, caddr=3rd -; (cXr (cYr m)) specifies element matrix[y][x]: e.g., (car (cadr m))=2nd element of 1st row -; - -(define (mat3 t00 t01 t02 t10 t11 t12 t20 t21 t22) - (list (list t00 t01 t02) - (list t10 t11 t12) - (list t20 t21 t22))) - -(define (mat3-identity) - (mat3 1.0 0.0 0.0 - 0.0 1.0 0.0 - 0.0 0.0 1.0)) - -; Transform an xy point using matrix m -; - -(define (transform-point m x y) - (let ((w (apply + (map * (caddr m) (list x y 1))))) - (set! w (if (zero? w) - 1.0 - (/ w))) - (list (* (+ (* (caar m) x) (* (cadar m) y) (caddar m)) w) ; newx - (* (+ (* (caadr m) x) (* (cadadr m) y) (caddr (cadr m))) w)))) ; newy - -; 'matrix-perspective' modifies a transform matrix given a source box (xywh) -; and four target corners (x1 y1 x2 y2 x3 y3 x4 y4) -; For a path, the source box would be the image. -; -(define (mat3-perspective m x y w h x1 y1 x2 y2 x3 y3 x4 y4) - (let ((scalex (if (zero? w) 1.0 (/ w))) - (scaley (if (zero? h) 1.0 (/ h)))) - (set! m (mat3-scale - (mat3-translate m (- x) (- y)) - scalex scaley)) - (let ((dx1 (- x2 x4)) - (dx2 (- x3 x4)) - (dx3 (- (+ x1 x4) x2 x3)) - (dy1 (- y2 y4)) - (dy2 (- y3 y4)) - (dy3 (- (+ y1 y4) y2 y3))) - (mat3-mult (if (and (zero? dx3) (zero? dy3)) - (mat3 ;; mapping is affine - (- x2 x1) (- x4 x2) x1 - (- y2 y1) (- y4 y2) y1 - 0.0 0.0 (caddr (caddr m))) - (let* ((det (- (* dx1 dy2) (* dy1 dx2))) - (t20 (if (zero? det) - 1.0 - (/ (- (* dx3 dy2) (* dy3 dx2)) det))) - (t21 (if (zero? det) - 1.0 - (/ (- (* dx1 dy3) (* dy1 dx3)) det)))) - (mat3 - (+ (- x2 x1) (* t20 x2)) (+ (- x3 x1) (* t21 x3)) x1 - (+ (- y2 y1) (* t20 y2)) (+ (- y3 y1) (* t21 y3)) y1 - t20 t21 1.0))) - m)))) - -(define (mat3-det m) - (- (+ (* (car (car m)) (cadr (cadr m)) (caddr (caddr m))) - (* (cadr (car m)) (caddr (cadr m)) (car (caddr m))) - (* (caddr (car m)) (car (cadr m)) (cadr (caddr m)))) - (+ (* (car (caddr m)) (cadr (cadr m)) (caddr (car m))) - (* (cadr (caddr m)) (caddr (cadr m)) (car (car m))) - (* (caddr (caddr m)) (car (cadr m)) (cadr (car m)))))) - -(define (mat3-invert m) - (let ((det (mat3-det m))) - (if (zero? det) - m - (begin - (set! det (/ det)) - (mat3 - (* (- (* (cadr (cadr m)) (caddr (caddr m))) - (* (caddr (cadr m)) (cadr (caddr m)))) det) - (* (- (* (caddr (car m)) (cadr (caddr m))) - (* (cadr (car m)) (caddr (caddr m)))) det) - (* (- (* (cadr (car m)) (caddr (cadr m))) - (* (caddr (car m)) (cadr (cadr m)))) det) - - (* (- (* (caddr (cadr m)) (car (caddr m))) - (* (car (cadr m)) (caddr (caddr m)))) det) - (* (- (* (car (car m)) (caddr (caddr m))) - (* (caddr (car m)) (car (caddr m)))) det) - (* (- (* (caddr (car m)) (car (cadr m))) - (* (car (car m)) (caddr (cadr m)))) det) - - (* (- (* (car (cadr m)) (cadr (caddr m))) - (* (cadr (cadr m)) (car (caddr m)))) det) - (* (- (* (cadr (car m)) (car (caddr m))) - (* (car (car m)) (cadr (caddr m)))) det) - (* (- (* (car (car m)) (cadr (cadr m))) - (* (cadr (car m)) (car (cadr m)))) det)))))) - -; multiplies two matrices and returns result. -; -(define (mat3-mult m1 m2) - (mat3 - (apply + (map * (car m1) (map car m2))) - (apply + (map * (car m1) (map cadr m2))) - (apply + (map * (car m1) (map caddr m2))) - - (apply + (map * (cadr m1) (map car m2))) - (apply + (map * (cadr m1) (map cadr m2))) - (apply + (map * (cadr m1) (map caddr m2))) - - (apply + (map * (caddr m1) (map car m2))) - (apply + (map * (caddr m1) (map cadr m2))) - (apply + (map * (caddr m1) (map caddr m2))))) - -(define (mat3-translate matrix x y) - (list - (map + (car matrix) (map * (make-list 3 x) (caddr matrix))) - (map + (cadr matrix) (map * (make-list 3 y) (caddr matrix))) - (caddr matrix) - ) - ) - -(define (mat3-scale matrix x y) - (list - (map * (car matrix) (make-list 3 x)) - (map * (cadr matrix) (make-list 3 y)) - (caddr matrix) - ) - ) - -(define (script-fu-sg-warp-text image layer use-path orig-path padding quality) - (let* ((env-path 0) - (env-stroke nil) - (recovery-info nil) - (warped-path 0) - (text-path 0) - (env-name "") - ) - (gimp-image-undo-group-start image) - (gimp-context-push) - (set! env-name (car (gimp-vectors-get-name (car (gimp-image-get-active-vectors image))))) - (set! env-path (car (gimp-vectors-copy - (car (gimp-image-get-active-vectors image))))) - (gimp-image-add-vectors image env-path 0) - (gimp-vectors-set-visible env-path FALSE) - (set! env-stroke (vector-ref (cadr (gimp-vectors-get-strokes env-path)) 0)) - (if (= use-path TRUE) - (set! text-path (car (gimp-vectors-copy orig-path))) - (set! text-path (car (gimp-vectors-new-from-text-layer image layer)))) - (gimp-image-add-vectors image text-path 0) - (set! recovery-info (warptext-square-off-envelope image text-path env-path env-stroke padding)) - (warptext-normalize-text-path text-path - (car (gimp-image-width image)) - (car (gimp-image-height image))) - (set! warped-path (warptext-map-bezier-envelope image text-path env-path quality)) - (warptext-transform-path (car recovery-info) warped-path) - (set! recovery-info (cadr recovery-info)) - (gimp-image-resize image - (car recovery-info) - (cadr recovery-info) - (caddr recovery-info) - (cadddr recovery-info)) - (gimp-image-remove-vectors image text-path) - (gimp-image-remove-vectors image env-path) - (gimp-context-pop) - (gimp-vectors-set-visible warped-path TRUE) - (gimp-vectors-set-name warped-path (string-append "warped - " env-name)) - (gimp-displays-flush) - (gimp-image-undo-group-end image) - ) - ) - -(script-fu-register "script-fu-sg-warp-text" - "Warp text..." - "Warp text to a four-point Bezier patch" - "Saul Goode" - "Saul Goode" - "July 2010" - "*" - SF-IMAGE "Image" 0 - SF-DRAWABLE "Layer" 0 - SF-TOGGLE "Use alternate path" FALSE - SF-VECTORS "Path" 0 - SF-ADJUSTMENT "Padding" (list 0 0 25 1 10 0 SF-SPINNER) - SF-ADJUSTMENT "Quality" (list 60 1 250 1 10 0 SF-SPINNER) - ) -(script-fu-menu-register "script-fu-sg-warp-text" - "/Filters/Distorts" - ) - -