home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_gimp.idb / usr / freeware / share / gimp / scripts / text-circle.scm.z / text-circle.scm
Encoding:
GIMP Script-Fu Script  |  1999-07-21  |  9.4 KB  |  228 lines
  1. ;; text-circle.scm -- a script for The GIMP 1.0
  2. ;; Author: Shuji Narazaki <narazaki@InetQ.or.jp>
  3. ;; Time-stamp: <1998/04/30 22:00:40 narazaki@InetQ.or.jp>
  4. ;; Version 2.4
  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-text (the-environment)))
  26.     (define script-fu-text-circle-text
  27.       "\"The GNU Image Manipulation Program Version 1.0 \""))
  28. (if (not (symbol-bound? 'script-fu-text-circle-radius (the-environment)))
  29.     (define script-fu-text-circle-radius 80))
  30. (if (not (symbol-bound? 'script-fu-text-circle-start-angle (the-environment)))
  31.     (define script-fu-text-circle-start-angle 0))
  32. (if (not (symbol-bound? 'script-fu-text-circle-fill-angle (the-environment)))
  33.     (define script-fu-text-circle-fill-angle 360))
  34. (if (not (symbol-bound? 'script-fu-text-circle-font-size (the-environment)))
  35.     (define script-fu-text-circle-font-size 18))
  36. (if (not (symbol-bound? 'script-fu-text-circle-antialias (the-environment)))
  37.     (define script-fu-text-circle-antialias TRUE))
  38. (if (not (symbol-bound? 'script-fu-text-circle-extra-pole (the-environment)))
  39.     (define script-fu-text-circle-extra-pole TRUE))
  40. (if (not (symbol-bound? 'script-fu-text-circle-font-foundry (the-environment)))
  41.     (define script-fu-text-circle-font-foundry "\"*\""))
  42. (if (not (symbol-bound? 'script-fu-text-circle-font-family (the-environment)))
  43.     (define script-fu-text-circle-font-family "\"helvetica\""))
  44. (if (not (symbol-bound? 'script-fu-text-circle-font-weight (the-environment)))
  45.     (define script-fu-text-circle-font-weight "\"*\""))
  46. (if (not (symbol-bound? 'script-fu-text-circle-font-slant (the-environment)))
  47.     (define script-fu-text-circle-font-slant "\"r\""))
  48. (if (not (symbol-bound? 'script-fu-text-circle-font-width (the-environment)))
  49.     (define script-fu-text-circle-font-width "\"*\""))
  50. (if (not (symbol-bound? 'script-fu-text-circle-font-spacing (the-environment)))
  51.     (define script-fu-text-circle-font-spacing "\"*\""))
  52. (if (not (symbol-bound? 'script-fu-text-circle-debug? (the-environment)))
  53.     (define script-fu-text-circle-debug? #f))
  54.  
  55. (define (script-fu-text-circle text radius start-angle fill-angle
  56.                    font-size antialias
  57.                    foundry family weight slant width spacing)
  58.   ;;(set! script-fu-text-circle-debug? #t)
  59.   (define extra-pole TRUE)        ; for debugging purpose
  60.   (define modulo fmod)            ; in R4RS way
  61.   (define (wrap-string str) (string-append "\"" str "\""))
  62.   (define (white-space-string? str)
  63.     (or (equal? " " str) (equal? "    " str)))
  64.   (let* ((drawable-size (* 2.0 (+ radius (* 2 font-size))))
  65.      (img (car (gimp-image-new drawable-size drawable-size RGB)))
  66.      (BG-layer (car (gimp-layer-new img drawable-size drawable-size
  67.                     RGBA_IMAGE "background" 100 NORMAL)))
  68.      (merged-layer #f)
  69.      (char-num (string-length text))
  70.      (radian-step 0)
  71.      (rad-90 (/ *pi* 2))
  72.      (center-x (/ drawable-size 2))
  73.      (center-y center-x)
  74.      ;; widths of " lAgy" and of "l Agy" will be different, because gimp-text
  75.      ;; strips spaces at the beginning of a string![Mon Apr 27 15:10:39 1998]
  76.      (fixed-pole0 "l Agy")
  77.      ;; the following used as real pad.
  78.      (fixed-pole " lAgy")
  79.      (font-infos (gimp-text-get-extents fixed-pole font-size PIXELS
  80.                         "*" family "*" slant "*" "*"))
  81.      (desc (nth 3 font-infos))
  82.      (extra 0)            ; extra is calculated from real layer
  83.      (angle-list #f)
  84.      (letter "")
  85.      (new-layer #f)
  86.      (index 0))
  87.     (gimp-image-disable-undo img)
  88.     (gimp-image-add-layer img BG-layer 0)
  89.     (gimp-edit-fill img BG-layer)
  90.     ;; change units
  91.     (set! start-angle-rad (* (/ (modulo start-angle 360) 360) 2 *pi*))
  92.     (set! fill-angle-rad (* (/ fill-angle 360) 2 *pi*))
  93.     (set! radian-step (/ fill-angle-rad char-num))
  94.     ;; set extra
  95.     (if (eq? extra-pole TRUE)
  96.     (let ((temp-pole-layer (car (gimp-text img -1 0 0
  97.                            fixed-pole0
  98.                            1 antialias
  99.                            font-size PIXELS
  100.                            "*" family "*" slant "*" "*"))))
  101.       (set! extra (car (gimp-drawable-width temp-pole-layer)))
  102.       (gimp-image-remove-layer img temp-pole-layer))
  103.     (set! extra 0))
  104.     ;; make width-list
  105.     ;;  In a situation,
  106.     ;; (car (gimp-drawable-width (car (gimp-text ...)))
  107.     ;; != (car (gimp-text-get_extent ...))
  108.     ;; Thus, I changed to gimp-text from gimp-text-get-extent at 2.2 !!
  109.     (let ((temp-list '())
  110.       (temp-str #f)
  111.       (temp-layer #f)
  112.       (scale 0)
  113.       (temp #f))
  114.       (set! index 0)
  115.       (while (< index char-num)
  116.     (set! temp-str (substring text index (+ index 1)))
  117.     (if (white-space-string? temp-str)
  118.         (set! temp-str "x"))
  119.     (set! temp-layer (car (gimp-text img -1 0 0
  120.                      temp-str
  121.                      1 antialias
  122.                      font-size PIXELS
  123.                      "*" family "*" slant "*" "*")))
  124.     (set! temp-list (cons (car (gimp-drawable-width temp-layer)) temp-list))
  125.     (gimp-image-remove-layer img temp-layer)
  126.     (set! index (+ index 1)))
  127.       (set! angle-list (nreverse temp-list))
  128.       (set! temp 0)
  129.       (set! angle-list
  130.         (mapcar (lambda (angle) 
  131.               (let ((tmp temp))
  132.             (set! temp (+ angle temp))
  133.             (+ tmp (/ angle 2))))
  134.             angle-list))
  135.       (set! scale (/ fill-angle-rad temp))
  136.       (set! angle-list (mapcar (lambda (angle) (* scale angle)) angle-list)))
  137.     (set! index 0)
  138.     (while (< index char-num)
  139.       (set! letter (substring text index (+ index 1)))
  140.       (if (not (white-space-string? letter))
  141.       ;; Running gimp-text with " " causes an error!
  142.       (let* ((new-layer (car (gimp-text img -1 0 0
  143.                         (if (eq? extra-pole TRUE)
  144.                         (string-append letter fixed-pole)
  145.                         letter)
  146.                         1 antialias
  147.                         font-size PIXELS
  148.                         "*" family "*" slant "*" "*")))
  149.          (width (car (gimp-drawable-width new-layer)))
  150.          (height (car (gimp-drawable-height new-layer)))
  151.          (rotate-radius (- (/ height 2) desc))
  152.          (new-width (- width extra))
  153.          (angle (+ start-angle-rad (- (nth index angle-list) rad-90))))
  154.         ;; delete fixed-pole
  155.         (gimp-layer-resize new-layer new-width height 0 0)
  156.         (set! width (car (gimp-drawable-width new-layer)))
  157.         (if (not script-fu-text-circle-debug?)
  158.         (begin
  159.           (gimp-layer-translate new-layer
  160.                     (+ center-x
  161.                        (* radius (cos angle))
  162.                        (* rotate-radius
  163.                           (cos (if (< 0 fill-angle-rad)
  164.                                angle
  165.                                (+ angle *pi*))))
  166.                        (- (/ width 2)))
  167.                     (+ center-y
  168.                        (* radius (sin angle))
  169.                        (* rotate-radius
  170.                           (sin (if (< 0 fill-angle-rad) 
  171.                                angle
  172.                                (+ angle *pi*))))
  173.                        (- (/ height 2))))
  174.           (gimp-rotate img new-layer 1 
  175.                    ((if (< 0 fill-angle-rad) + -) angle rad-90))))))
  176.       (set! index (+ index 1)))
  177.     (gimp-layer-set-visible BG-layer 0)
  178.     (if (not script-fu-text-circle-debug?)
  179.     (begin
  180.       (set! merged-layer 
  181.         (car (gimp-image-merge-visible-layers img CLIP-TO-IMAGE)))
  182.       (gimp-layer-set-name merged-layer 
  183.                    (if (< (length text) 16)
  184.                    (wrap-string text)
  185.                    "Text Circle"))))
  186.     (gimp-layer-set-visible BG-layer 1)
  187.     (gimp-image-enable-undo img)
  188.     (gimp-image-clean-all img)
  189.     (gimp-display-new img)
  190.     (set! script-fu-text-circle-text (wrap-string text))
  191.     (set! script-fu-text-circle-radius radius)
  192.     (set! script-fu-text-circle-start-angle start-angle)
  193.     (set! script-fu-text-circle-fill-angle fill-angle)
  194.     (set! script-fu-text-circle-font-size font-size)
  195.     (set! script-fu-text-circle-antialias antialias)
  196.     (set! script-fu-text-circle-extra-pole extra-pole)
  197.     (set! script-fu-text-circle-font-foundry (wrap-string foundry))
  198.     (set! script-fu-text-circle-font-family (wrap-string family))
  199.     (set! script-fu-text-circle-font-weight (wrap-string weight))
  200.     (set! script-fu-text-circle-font-slant (wrap-string slant))
  201.     (set! script-fu-text-circle-font-width (wrap-string width))
  202.     (set! script-fu-text-circle-font-spacing (wrap-string spacing))
  203.     (gimp-displays-flush)))
  204.  
  205. (script-fu-register 
  206.  "script-fu-text-circle"
  207.  "<Toolbox>/Xtns/Script-Fu/Logos/Text Circle"
  208.  "Render the specified text along the perimeter of a circle"
  209.  "Shuji Narazaki <narazaki@InetQ.or.jp>"
  210.  "Shuji Narazaki"
  211.  "1997-1998"
  212.  ""
  213.  SF-VALUE "Text" script-fu-text-circle-text
  214.  SF-VALUE "Radius" (number->string script-fu-text-circle-radius)
  215.  SF-VALUE "Start-angle[-180:180]" (number->string script-fu-text-circle-start-angle)
  216.  SF-VALUE "Fill-angle [-360:360]" (number->string script-fu-text-circle-fill-angle)
  217.  SF-VALUE "Font Size (pixel)" (number->string script-fu-text-circle-font-size)
  218.  SF-TOGGLE "Antialias" script-fu-text-circle-antialias
  219.  SF-VALUE "Font Foundry" script-fu-text-circle-font-foundry
  220.  SF-VALUE " - Family" script-fu-text-circle-font-family
  221.  SF-VALUE " - Weight" script-fu-text-circle-font-weight
  222.  SF-VALUE " - Slant" script-fu-text-circle-font-slant
  223.  SF-VALUE " - Width" script-fu-text-circle-font-width
  224.  SF-VALUE " - Spacing" script-fu-text-circle-font-spacing
  225. )
  226.  
  227. ;; text-circle.scm ends here
  228.