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 / beveled-pattern-arrow.scm.z / beveled-pattern-arrow.scm
Encoding:
Text File  |  1999-07-21  |  4.5 KB  |  146 lines
  1. ; The GIMP -- an image manipulation program
  2. ; Copyright (C) 1995 Spencer Kimball and Peter Mattis
  3. ; 
  4. ; Beveled pattern arrow for web pages
  5. ; Copyright (C) 1997 Federico Mena Quintero
  6. ; federico@nuclecu.unam.mx
  7. ; 
  8. ; This program is free software; you can redistribute it and/or modify
  9. ; it under the terms of the GNU General Public License as published by
  10. ; the Free Software Foundation; either version 2 of the License, or
  11. ; (at your option) any later version.
  12. ; 
  13. ; This program is distributed in the hope that it will be useful,
  14. ; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. ; GNU General Public License for more details.
  17. ; 
  18. ; You should have received a copy of the GNU General Public License
  19. ; along with this program; if not, write to the Free Software
  20. ; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22.  
  23. (define (map proc seq)
  24.   (if (null? seq)
  25.       '()
  26.       (cons (proc (car seq))
  27.         (map proc (cdr seq)))))
  28.  
  29. (define (for-each proc seq)
  30.   (if (not (null? seq))
  31.       (begin
  32.     (proc (car seq))
  33.     (for-each proc (cdr seq)))))
  34.  
  35. (define (make-point x y)
  36.   (cons x y))
  37.  
  38. (define (point-x p)
  39.   (car p))
  40.  
  41. (define (point-y p)
  42.   (cdr p))
  43.  
  44. (define (point-list->double-array point-list)
  45.   (let* ((how-many (length point-list))
  46.      (a (cons-array (* 2 how-many) 'double))
  47.      (count 0))
  48.     (for-each (lambda (p)
  49.         (aset a (* count 2) (point-x p))
  50.         (aset a (+ 1 (* count 2)) (point-y p))
  51.         (set! count (+ count 1)))
  52.           point-list)
  53.     a))
  54.  
  55. (define (rotate-points points size orientation)
  56.   (map (lambda (p)
  57.      (let ((px (point-x p))
  58.            (py (point-y p)))
  59.        (cond ((eq? orientation 'right) (make-point px py))
  60.          ((eq? orientation 'left) (make-point (- size px) py))
  61.          ((eq? orientation 'up) (make-point py (- size px)))
  62.          ((eq? orientation 'down) (make-point py px)))))
  63.        points))
  64.  
  65. (define (make-arrow size offset)
  66.   (list (make-point offset offset)
  67.     (make-point (- size offset) (/ size 2))
  68.     (make-point offset (- size offset))))
  69.  
  70. (define (script-fu-beveled-pattern-arrow size orientation pattern)
  71.   (let* ((old-bg-color (car (gimp-palette-get-background)))
  72.      (img (car (gimp-image-new size size RGB)))
  73.      (background (car (gimp-layer-new img size size RGB_IMAGE "Arrow" 100 NORMAL)))
  74.      (bumpmap (car (gimp-layer-new img size size RGB_IMAGE "Bumpmap" 100 NORMAL)))
  75.      (big-arrow (point-list->double-array (rotate-points (make-arrow size 6) size orientation)))
  76.      (med-arrow (point-list->double-array (rotate-points (make-arrow size 7) size orientation)))
  77.      (small-arrow (point-list->double-array (rotate-points (make-arrow size 8) size orientation))))
  78.  
  79.     (gimp-image-disable-undo img)
  80.     (gimp-image-add-layer img background -1)
  81.     (gimp-image-add-layer img bumpmap -1)
  82.  
  83.     ; Create pattern layer
  84.  
  85.     (gimp-palette-set-background '(0 0 0))
  86.     (gimp-edit-fill img background)
  87.     (gimp-patterns-set-pattern pattern)
  88.     (gimp-bucket-fill img background PATTERN-BUCKET-FILL NORMAL 100 0 FALSE 0 0)
  89.  
  90.     ; Create bumpmap layer
  91.  
  92.     (gimp-edit-fill img bumpmap)
  93.  
  94.     (gimp-palette-set-background '(127 127 127))
  95.     (gimp-rect-select img 1 1 (- size 2) (- size 2) REPLACE FALSE 0)
  96.     (gimp-edit-fill img bumpmap)
  97.  
  98.     (gimp-palette-set-background '(255 255 255))
  99.     (gimp-rect-select img 2 2 (- size 4) (- size 4) REPLACE FALSE 0)
  100.     (gimp-edit-fill img bumpmap)
  101.  
  102.     (gimp-palette-set-background '(127 127 127))
  103.     (gimp-free-select img 6 big-arrow REPLACE TRUE FALSE 0)
  104.     (gimp-edit-fill img bumpmap)
  105.  
  106.     (gimp-palette-set-background '(0 0 0))
  107.     (gimp-free-select img 6 med-arrow REPLACE TRUE FALSE 0)
  108.     (gimp-edit-fill img bumpmap)
  109.  
  110.     (gimp-selection-none img)
  111.  
  112.     ; Bumpmap
  113.  
  114.     (plug-in-bump-map 1 img background bumpmap 135 45 2 0 0 0 0 TRUE FALSE 0)
  115.  
  116.     ; Darken arrow
  117.  
  118.     (gimp-palette-set-background '(255 255 255))
  119.     (gimp-edit-fill img bumpmap)
  120.  
  121.     (gimp-palette-set-background '(192 192 192))
  122.     (gimp-free-select img 6 small-arrow REPLACE TRUE FALSE 0)
  123.     (gimp-edit-fill img bumpmap)
  124.  
  125.     (gimp-selection-none img)
  126.  
  127.     (gimp-layer-set-mode bumpmap MULTIPLY)
  128.  
  129.     (gimp-image-flatten img)
  130.  
  131.     (gimp-palette-set-background old-bg-color)
  132.     (gimp-image-enable-undo img)
  133.     (gimp-display-new img)))
  134.  
  135.  
  136. (script-fu-register "script-fu-beveled-pattern-arrow"
  137.             "<Toolbox>/Xtns/Script-Fu/Web page themes/Beveled pattern/Arrow"
  138.             "Beveled pattern arrow"
  139.             "Federico Mena Quintero"
  140.             "Federico Mena Quintero"
  141.             "July 1997"
  142.             ""
  143.             SF-VALUE "Size"        "32"
  144.             SF-VALUE "Orientation" "'right"
  145.             SF-VALUE "Pattern"     "\"Wood\"")
  146.