home *** CD-ROM | disk | FTP | other *** search
/ PC World 2001 February / PCWorld_2001-02_cd.bin / Software / Topware / gimp / gimp-setup-20001226.exe / Main / text-circle.scm < prev    next >
Encoding:
GIMP Script-Fu Script  |  2000-12-27  |  6.7 KB  |  183 lines
  1. ;; text-circle.scm -- a script for The GIMP 1.1
  2. ;; Author: Shuji Narazaki <narazaki@gimp.org>
  3. ;; Time-stamp: <1998/11/25 13:26:51 narazaki@gimp.org>
  4. ;; Version 2.5
  5. ;; Thanks:
  6. ;;   jseymour@jimsun.LinxNet.com (Jim Seymour)
  7. ;;   Sven Neumann <neumanns@uni-duesseldorf.de>
  8.  
  9. ;; Note:
  10. ;;  Please remove /usr/local/share/gimp/scripts/circle-logo.scm, which is
  11. ;;  obsolete version of this script.
  12.  
  13. ;; Implementation memo:
  14. ;; This script uses "extra-pole".
  15. ;; Namely, when rendering a letter, gimp-text is invoked with the letter
  16. ;; followed by " lAgy", then strips it by gimp-layer-resize. I call this " lAgy"
  17. ;; extra-pole. Why is it needed?
  18. ;; Since a text is located by its left-upper corner's position, THERE IS NO WAY
  19. ;; TO PLACE LETTERS ON A BASE LINE!
  20. ;; (FURTHERMORE, GIMP-TEXT EATS WHITESPACES AT THE BEGINNING/END OF LINE.)
  21. ;; Thus, as a dirty trick, by adding tall letters: "lA", and "gy" which have
  22. ;; large descent value to each letter temporally, most letters in most fonts
  23. ;; are aligned correctly. But don't expect completeness :-<
  24.  
  25. (if (not (symbol-bound? 'script-fu-text-circle-debug? (the-environment)))
  26.     (define script-fu-text-circle-debug? #f))
  27.  
  28. (define (script-fu-text-circle text radius start-angle fill-angle
  29.                    font-size antialias font-name)
  30.   ;;(set! script-fu-text-circle-debug? #t)
  31.   (define extra-pole TRUE)        ; for debugging purpose
  32.   (define modulo fmod)            ; in R4RS way
  33.   (define (wrap-string str) (string-append "\"" str "\""))
  34.   (define (white-space-string? str)
  35.     (or (equal? " " str) (equal? "    " str)))
  36.   (let* ((drawable-size (* 2.0 (+ radius (* 2 font-size))))
  37.      (img (car (gimp-image-new drawable-size drawable-size RGB)))
  38.      (BG-layer (car (gimp-layer-new img drawable-size drawable-size
  39.                     RGBA_IMAGE "background" 100 NORMAL)))
  40.      (merged-layer #f)
  41.      (char-num (string-length text))
  42.      (radian-step 0)
  43.      (rad-90 (/ *pi* 2))
  44.      (center-x (/ drawable-size 2))
  45.      (center-y center-x)
  46.      ;; widths of " lAgy" and of "l Agy" will be different, because gimp-text
  47.      ;; strips spaces at the beginning of a string![Mon Apr 27 15:10:39 1998]
  48.      (fixed-pole0 "l Agy")
  49.      ;; the following used as real pad.
  50.      (fixed-pole " lAgy")
  51.      (font-infos (gimp-text-get-extents-fontname fixed-pole font-size
  52.                              PIXELS font-name))
  53.      (desc (nth 3 font-infos))
  54.      (extra 0)            ; extra is calculated from real layer
  55.      (angle-list #f)
  56.      (letter "")
  57.      (new-layer #f)
  58.      (index 0))
  59.     (gimp-image-undo-disable img)
  60.     (gimp-image-add-layer img BG-layer 0)
  61.     (gimp-edit-fill BG-layer BG-IMAGE-FILL)
  62.     ;; change units
  63.     (set! start-angle-rad (* (/ (modulo start-angle 360) 360) 2 *pi*))
  64.     (set! fill-angle-rad (* (/ fill-angle 360) 2 *pi*))
  65.     (set! radian-step (/ fill-angle-rad char-num))
  66.     ;; set extra
  67.     (if (eq? extra-pole TRUE)
  68.     (let ((temp-pole-layer (car (gimp-text-fontname img -1 0 0
  69.                            fixed-pole0
  70.                            1 antialias
  71.                            font-size PIXELS
  72.                            font-name))))
  73.       (set! extra (car (gimp-drawable-width temp-pole-layer)))
  74.       (gimp-image-remove-layer img temp-pole-layer))
  75.     (set! extra 0))
  76.     ;; make width-list
  77.     ;;  In a situation,
  78.     ;; (car (gimp-drawable-width (car (gimp-text ...)))
  79.     ;; != (car (gimp-text-get_extent ...))
  80.     ;; Thus, I changed to gimp-text from gimp-text-get-extent at 2.2 !!
  81.     (let ((temp-list '())
  82.       (temp-str #f)
  83.       (temp-layer #f)
  84.       (scale 0)
  85.       (temp #f))
  86.       (set! index 0)
  87.       (while (< index char-num)
  88.     (set! temp-str (substring text index (+ index 1)))
  89.     (if (white-space-string? temp-str)
  90.         (set! temp-str "x"))
  91.     (set! temp-layer (car (gimp-text-fontname img -1 0 0
  92.                           temp-str
  93.                           1 antialias
  94.                           font-size PIXELS
  95.                           font-name)))
  96.     (set! temp-list (cons (car (gimp-drawable-width temp-layer)) temp-list))
  97.     (gimp-image-remove-layer img temp-layer)
  98.     (set! index (+ index 1)))
  99.       (set! angle-list (nreverse temp-list))
  100.       (set! temp 0)
  101.       (set! angle-list
  102.         (mapcar (lambda (angle)
  103.               (let ((tmp temp))
  104.             (set! temp (+ angle temp))
  105.             (+ tmp (/ angle 2))))
  106.             angle-list))
  107.       (set! scale (/ fill-angle-rad temp))
  108.       (set! angle-list (mapcar (lambda (angle) (* scale angle)) angle-list)))
  109.     (set! index 0)
  110.     (while (< index char-num)
  111.       (set! letter (substring text index (+ index 1)))
  112.       (if (not (white-space-string? letter))
  113.       ;; Running gimp-text with " " causes an error!
  114.       (let* ((new-layer
  115.           (car (gimp-text-fontname img -1 0 0
  116.                        (if (eq? extra-pole TRUE)
  117.                            (string-append letter fixed-pole)
  118.                            letter)
  119.                        1 antialias
  120.                        font-size PIXELS
  121.                        font-name)))
  122.          (width (car (gimp-drawable-width new-layer)))
  123.          (height (car (gimp-drawable-height new-layer)))
  124.          (rotate-radius (- (/ height 2) desc))
  125.          (new-width (- width extra))
  126.          (angle (+ start-angle-rad (- (nth index angle-list) rad-90))))
  127.         ;; delete fixed-pole
  128.         (gimp-layer-resize new-layer new-width height 0 0)
  129.         (set! width (car (gimp-drawable-width new-layer)))
  130.         (if (not script-fu-text-circle-debug?)
  131.         (begin
  132.           (gimp-layer-translate new-layer
  133.                     (+ center-x
  134.                        (* radius (cos angle))
  135.                        (* rotate-radius
  136.                           (cos (if (< 0 fill-angle-rad)
  137.                                angle
  138.                                (+ angle *pi*))))
  139.                        (- (/ width 2)))
  140.                     (+ center-y
  141.                        (* radius (sin angle))
  142.                        (* rotate-radius
  143.                           (sin (if (< 0 fill-angle-rad)
  144.                                angle
  145.                                (+ angle *pi*))))
  146.                        (- (/ height 2))))
  147.           (gimp-rotate new-layer 1
  148.                    ((if (< 0 fill-angle-rad) + -) angle rad-90))))))
  149.       (set! index (+ index 1)))
  150.     (gimp-layer-set-visible BG-layer 0)
  151.     (if (not script-fu-text-circle-debug?)
  152.     (begin
  153.       (set! merged-layer
  154.         (car (gimp-image-merge-visible-layers img CLIP-TO-IMAGE)))
  155.       (gimp-layer-set-name merged-layer
  156.                    (if (< (length text) 16)
  157.                    (wrap-string text)
  158.                    "Text Circle"))))
  159.     (gimp-layer-set-visible BG-layer 1)
  160.     (gimp-image-undo-enable img)
  161.     (gimp-image-clean-all img)
  162.     (gimp-display-new img)
  163.     (gimp-displays-flush)))
  164.  
  165. (script-fu-register
  166.  "script-fu-text-circle"
  167.  _"<Toolbox>/Xtns/Script-Fu/Logos/Text Circle..."
  168.  "Render the specified text along the perimeter of a circle"
  169.  "Shuji Narazaki <narazaki@gimp.org>"
  170.  "Shuji Narazaki"
  171.  "1997-1998"
  172.  ""
  173.  SF-STRING     _"Text" "The GNU Image Manipulation Program Version 1.1 "
  174.  SF-ADJUSTMENT _"Radius" '(80 1 8000 1 1 0 1)
  175.  SF-ADJUSTMENT _"Start Angle" '(0 -180 180 1 1 0 1)
  176.  SF-ADJUSTMENT _"Fill Angle" '(360 -360 360 1 1 0 1)
  177.  SF-ADJUSTMENT _"Font Size (pixels)" '(18 1 1000 1 1 0 1)
  178.  SF-TOGGLE     _"Antialias" TRUE
  179.  SF-FONT       _"Font" "-adobe-helvetica-bold-r-normal-*-30-*-*-*-p-*-*-*"
  180. )
  181.  
  182. ;; text-circle.scm ends here
  183.