home *** CD-ROM | disk | FTP | other *** search
/ PC World 2001 February / PCWorld_2001-02_cd.bin / Software / Topware / gimp / gimp-setup-20001226.exe / Main / beveled-pattern-arrow.scm < prev    next >
Encoding:
Text File  |  2000-12-27  |  4.8 KB  |  149 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 ((= orientation 0) (make-point px py))           ; right
  60.          ((= orientation 1) (make-point (- size px) py))  ; left
  61.          ((= orientation 2) (make-point py (- size px)))  ; up
  62.          ((= orientation 3) (make-point py px)))))        ; down
  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-undo-disable 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 background BG-IMAGE-FILL)
  87.     (gimp-patterns-set-pattern pattern)
  88.     (gimp-bucket-fill background PATTERN-BUCKET-FILL NORMAL 100 0 FALSE 0 0)
  89.  
  90.     ; Create bumpmap layer
  91.  
  92.     (gimp-edit-fill bumpmap BG-IMAGE-FILL)
  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 bumpmap BG-IMAGE-FILL)
  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 bumpmap BG-IMAGE-FILL)
  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 bumpmap BG-IMAGE-FILL)
  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 bumpmap BG-IMAGE-FILL)
  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 bumpmap BG-IMAGE-FILL)
  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 bumpmap BG-IMAGE-FILL)
  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-undo-enable 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-ADJUSTMENT _"Size"     '(32 5 150 1 10 0 1)
  144.             SF-OPTION     _"Orientation" '(_"Right" 
  145.                             _"Left" 
  146.                             _"Up" 
  147.                             _"Down")
  148.             SF-PATTERN    _"Pattern"     "Wood")
  149.