Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch sg-viktoria
Excluding Merge-Ins
This is equivalent to a diff from
7defaef104
to 20b50733b0
|
2013-04-19
| | |
| 21:20 |
|
Leaf
check-in: 20b50733b0 user: saul tags: sg-viktoria
|
| 03:24 |
|
check-in: fff16b68fe user: saul tags: sg-viktoria
|
|
2013-04-07
| | |
| 01:23 |
|
check-in: bb41605959 user: saul tags: trunk
|
|
2013-04-06
| | |
| 17:06 |
|
check-in: c84be48776 user: saul tags: sg-viktoria
|
|
2013-04-05
| | |
| 22:24 |
|
check-in: 7defaef104 user: saul tags: trunk
|
| 10:02 |
|
check-in: 6553bf9eaa user: saul tags: trunk
|
| | |
Deleted sg-align-down.scm.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
; 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"
"<Image>/Layer"
)
(script-fu-menu-register "script-fu-sg-align-down"
"<Layers>"
)
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
Deleted sg-anti-crop.scm.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
; 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"
"<Image>/Layer"
)
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
Deleted sg-channel-blend.scm.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
; 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"
"<Channels>/"
)
(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"
"<Channels>/"
)
(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"
"<Layers>/"
)
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
Deleted sg-copy-mask-from-above.scm.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
|
; 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 <Layers> menu
)
(script-fu-menu-register "script-fu-sg-copy-mask-from-above"
"<Layers>"
)
(script-fu-menu-register "script-fu-sg-copy-mask-from-above"
"<Image>/Layer/Mask/Modify"
)
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
Deleted sg-extend-layer.scm.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
; 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"
"<Image>/Layer/Resize"
)
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
Deleted sg-fit-face.scm.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
; 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"
"<Image>/Layer")
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
Deleted sg-isolate.scm.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
|
; 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"
"<Image>/Edit/Clear"
)
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
Deleted sg-layer-fit-in-selection.scm.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
; 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"
"<Image>/Layer/Resize"
)
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
Deleted sg-mirror-dup.scm.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
;; 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"
"<Image>/Filters/Map/"
)
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
Deleted sg-quantize.scm.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
; 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"
"<Image>/Colors"
)
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
Deleted sg-scale-to-selection.scm.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
|
; 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"
"<Image>/Layer/Resize"
)
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
Deleted sg-tooninator.scm.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
|
; 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"
"<Image>/Filters/Artistic/"
)
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
Changes to sg-viktoria.scm.
1
2
3
4
5
6
7
8
|
(define (script-fu-sg-viktoria orig-image orig-drawable)
(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
color
1
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
; 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
color
1
|
| ︙ | | | ︙ | |
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
|
(gimp-by-color-select drawable
color
1
CHANNEL-OP-SUBTRACT
FALSE
FALSE
0
0 ) )
(not (zero? (car (gimp-selection-is-empty image)))) )
(define (create-table-image)
(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 ))
)
(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)))
(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" )))
(loop (cdr xs)
(not text?) )))
(gimp-context-pop)
table-image
)
)
; MAIN processing starts here
(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))) )
(unless (zero? (car (gimp-image-base-type image)))
(gimp-image-convert-rgb image) )
(gimp-image-convert-indexed image
NO-DITHER
MAKE-PALETTE
3
FALSE
FALSE
"")
(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)))
(let ((rows (let loop ((y 0)
(rows '()) )
(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)) )
(if (= start-row y)
(reverse rows)
(loop (succ y)
(cons (cons start-row y) rows) ))))))
(let ((cols (let loop ((x 0)
(cols '()) )
(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)) )
(if (= start-col x)
(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-threshold layer 127 255)
(gimp-image-convert-grayscale image)
(set! rows
(let loop-rows ((rows rows)
(row-result '()) )
(if (null? rows)
(reverse row-result)
(let ((row (map (lambda (x)
(zero? (vector-ref (cadr (gimp-drawable-get-pixel layer x (car rows))) 0)) )
cols) ))
(let rle ((cols row)
(result '()) )
(let ((rest (member (not (car cols)) cols)))
(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) ))))))))
(set! rows
(let loop ((rows rows)
(result '())
(rvs? #t) )
(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-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)
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<
<
<
<
<
<
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
<
<
|
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
|
>
|
<
<
|
<
<
<
<
<
<
<
<
<
<
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
|
|
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
|
|
|
|
>
>
|
>
|
>
>
>
>
>
|
<
|
|
<
<
>
>
|
<
<
|
|
>
|
>
|
>
>
>
>
>
>
>
|
|
<
>
>
>
>
|
<
<
<
<
|
|
|
<
<
<
<
<
<
<
<
<
|
|
|
|
>
>
>
|
>
>
>
>
>
|
>
>
|
|
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
|
(gimp-by-color-select drawable
color
1
CHANNEL-OP-SUBTRACT
FALSE
FALSE
0
0 ))
(not (zero? (car (gimp-selection-is-empty 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)))
(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
(gimp-image-select-contiguous-color table-image
CHANNEL-OP-ADD
table-layer
(+ (car xs) 2)
(+ (car ys) 2) )
(loop-rows (cdr ys)) )))))
(gimp-context-set-foreground '(228 228 228))
(gimp-edit-fill table-layer FOREGROUND-FILL)
(gimp-selection-none table-image)
(gimp-brush-delete brush)
(gimp-context-set-foreground '(0 0 0))
(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) )
(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
3
FALSE
FALSE
"")
(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)) )
(if (= start-row y)
(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)) )
(if (= start-col x)
(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 '()) )
(if (null? rows)
(reverse row-result)
(let ((row (map (lambda (x)
(zero? (vector-ref (cadr (gimp-drawable-get-pixel layer x (car rows))) 0)) )
cols) ))
(let rle ((cols row)
(result '()) )
(let ((rest (member (not (car cols)) cols)))
(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? #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))
(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"
"<Image>/File/Create"
)
|
Deleted sg-warptext.scm.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
|
; 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"
"<Image>/Filters/Distorts"
)
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|