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