home *** CD-ROM | disk | FTP | other *** search
/ PC World 2001 February / PCWorld_2001-02_cd.bin / Software / Topware / gimp / gimp-setup-20001226.exe / Main / trochoid.scm < prev    next >
Encoding:
GIMP Script-Fu Script  |  2000-12-27  |  13.9 KB  |  403 lines
  1. ;;; trochoid.scm -*-scheme-*-
  2. ;;; Time-stamp: <1997/06/13 23:15:23 narazaki@InetQ.or.jp>
  3. ;;; This file is a part of:
  4. ;;;   The GIMP (Copyright (C) 1995 Spencer Kimball and Peter Mattis)
  5. ;;; Author: Shuji Narazaki (narazaki@InetQ.or.jp)
  6. ;;; Version 1.0
  7.  
  8. ;;; Code:
  9.  
  10. (define (script-fu-trochoid base-radius-f wheel-radius-f pen-pos hue-rate
  11.                 erase-before-draw brush-details)
  12.   (if 'not-guile (define modulo fmod))
  13.   (define (floor x) (- x (fmod x 1)))
  14.   (define *prime-table*
  15.     '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97))
  16.  
  17.   (define (LCM x y)            ; Least Common Multiple
  18.     (define (divide? x y) (= 0 (modulo x y)))
  19.     (define (factorize x)
  20.       (define (f-aux x p-list result)
  21.     (cond ((= x 1)
  22.            (nreverse result))
  23.           ((null? p-list)
  24.            (nreverse (cons (list x 1) result)))
  25.           ((divide? x (car p-list))
  26.            (let ((times 1)
  27.              (p (car p-list)))
  28.          (set! x (/ x p))
  29.          (while (divide? x p)
  30.             (set! times (+ times 1))
  31.             (set! x (/ x p)))
  32.          (f-aux x (cdr p-list) (cons (list p times) result))))
  33.           ('else (f-aux x (cdr p-list) result))))
  34.       (f-aux x *prime-table* '()))
  35.     (define (extend-prime-table limit)
  36.       (let ((index (+ (car *prime-table*) 1)))
  37.     (while (< index limit)
  38.            (let ((prime? #t)
  39.              (table *prime-table*))
  40.          (while (and (not (null? table)) prime?)
  41.             (if (divide? index (car table))
  42.                 (set! prime? #f)
  43.                 (set! table (cdr table))))
  44.          (if prime?
  45.              (set! *prime-table*
  46.                (nreverse (cons index (nreverse *prime-table*))))))
  47.            (set! index (+ index 1)))))
  48.     (define (aux l1 l2 result)
  49.       (cond ((and (null? l1) (null? l2)) result)
  50.         ((null? l1) (append l2 result))
  51.         ((null? l2) (append l1 result))
  52.         ((= (car (car l1)) (car (car l2)))
  53.          (aux (cdr l1) (cdr l2) (cons (list (car (car l1))
  54.                         (max (cadr (car l1))
  55.                              (cadr (car l2))))
  56.                       result)))
  57.         ((< (car (car l1)) (car (car l2)))
  58.          (aux (cdr l1) l2 (cons (car l1) result)))
  59.         ('else
  60.          (aux l1 (cdr l2) (cons (car l2) result)))))
  61.     (if  (< (pow (car (reverse *prime-table*)) 2) (max x y))
  62.      (extend-prime-table (sqrt (max x y))))
  63.     (let ((f-list (aux (factorize x) (factorize y) '()))
  64.       (result 1))
  65.       (while (not (null? f-list))
  66.          (set! result (* (pow (car (car f-list)) (cadr (car f-list))) result))
  67.          (set! f-list (cdr f-list)))
  68.       result))
  69.  
  70.   (define (rgb-to-hsv rgb hsv)
  71.     (let* ((red (floor (nth 0 rgb)))
  72.        (green (floor (nth 1 rgb)))
  73.        (blue (floor (nth 2 rgb)))
  74.        (h 0.0)
  75.        (s 0.0)
  76.        (minv (min red (min green blue)))
  77.        (maxv (max red (max green blue)))
  78.        (v maxv)
  79.        (delta 0))
  80.       (if (not (= 0 maxv))
  81.       (set! s (/ (* (- maxv minv) 255.0) maxv))
  82.       (set! s 0.0))
  83.       (if (= 0.0 s)
  84.       (set! h 0.0)
  85.       (begin
  86.         (set! delta (- maxv minv))
  87.         (cond ((= maxv red)
  88.            (set! h (/ (- green blue) delta)))
  89.           ((= maxv green)
  90.            (set! h (+ 2.0 (/ (- blue red) delta))))
  91.           ((= maxv blue)
  92.            (set! h (+ 4.0 (/ (- red green) delta)))))
  93.         (set! h (* 42.5 h))
  94.         (if (< h 0.0)
  95.         (set! h (+ h 255.0)))
  96.         (if (< 255 h)
  97.         (set! h (- h 255.0)))))
  98.       (set-car! hsv (floor h))
  99.       (set-car! (cdr hsv) (floor s))
  100.       (set-car! (cddr hsv) (floor v))))
  101.  
  102. ;;; hsv-to-rgb that does not consume new cons cell
  103.   (define (hsv-to-rgb hsv rgb)
  104.     (let ((h (nth 0 hsv))
  105.       (s (nth 1 hsv))
  106.       (v (nth 2 hsv))
  107.       (hue 0)
  108.       (saturation 0)
  109.       (value 0))
  110.       (if (= s 0)
  111.       (begin
  112.         (set! h v)
  113.         (set! s v))
  114.       (let ((f 0)
  115.         (p 0)
  116.         (q 0)
  117.         (t 0))
  118.         (set! hue (/ (* 6 h) 255))
  119.         (if (= hue 6.0)
  120.         (set! hue 0.0))
  121.         (set! saturation (/ s  255.0))
  122.         (set! value (/ v 255.0))
  123.         (set! f (- hue (floor hue)))
  124.         (set! p (* value (- 1.0 saturation)))
  125.         (set! q (* value (- 1.0 (* saturation f))))
  126.         (set! t (* value (- 1.0 (* saturation (- 1.0 f)))))
  127.         (let ((tmp (floor hue)))
  128.           (cond ((= 0 tmp)
  129.              (set! h (* value 255))
  130.              (set! s (* t 255))
  131.              (set! v (* p 255)))
  132.             ((= 1 tmp)
  133.              (set! h (* q 255))
  134.              (set! s (* value 255))
  135.              (set! v (* p 255)))
  136.             ((= 2 tmp)
  137.              (set! h (* p 255))
  138.              (set! s (* value 255))
  139.              (set! v (* t 255)))
  140.             ((= 3 tmp)
  141.              (set! h (* p 255))
  142.              (set! s (* q 255))
  143.              (set! v (* value 255)))
  144.             ((= 4 tmp)
  145.              (set! h (* t 255))
  146.              (set! s (* p 255))
  147.              (set! v (* value 255)))
  148.             ((= 5 tmp)
  149.              (set! h (* value 255))
  150.              (set! s (* p 255))
  151.              (set! v (* q 255)))))))
  152.       (set-car! rgb h)
  153.       (set-car! (cdr rgb) s)
  154.       (set-car! (cddr rgb) v)))
  155.   
  156.   ;; segment is
  157.   ;;   filled-index (integer)
  158.   ;;   size as number of points (integer)
  159.   ;;   vector (which size is 2 * size)
  160.   (define (make-segment length x y)
  161.     (if (< 64 length)
  162.     (set! length 64))
  163.     (if (< length 5)
  164.     (set! length 5))
  165.     (let ((vec (cons-array (* 2 length) 'double)))
  166.       (aset vec 0 x)
  167.       (aset vec 1 y)
  168.       (list 1 length vec)))
  169.  
  170.   ;; accessors
  171.   (define (segment-filled-size segment) (car segment))
  172.   (define (segment-max-size segment) (cadr segment))
  173.   (define (segment-strokes segment) (caddr segment))
  174.  
  175.   (define (update-segment! center-x center-y angle1 rad1 angle2 rad2 segment)
  176.     (define (fill-segment! new-x new-y segment)
  177.       (define (shift-segment! segment)
  178.     (let ((base 0)
  179.           (size (cadr segment))
  180.           (vec (caddr segment))
  181.           (offset 2))
  182.       (while (< base offset)
  183.          (aset vec (* 2 base)
  184.                (aref vec (* 2 (- size (- offset base)))))
  185.          (aset vec (+ (* 2 base) 1)
  186.                (aref vec (+ (* 2 (- size (- offset base))) 1)))
  187.          (set! base (+ base 1)))
  188.       (set-car! segment base)))
  189.       (let ((base (car segment))
  190.         (size (cadr segment))
  191.         (vec (caddr segment)))
  192.     (if (= base 0)
  193.         (begin
  194.           (shift-segment! segment)
  195.           (set! base (segment-filled-size segment))))
  196.     (if (and (= new-x (aref vec (* 2 (- base 1))))
  197.          (= new-y (aref vec (+ (* 2 (- base 1)) 1))))
  198.         #f
  199.         (begin
  200.           (aset vec (* 2 base) new-x)
  201.           (aset vec (+ (* 2 base) 1) new-y)
  202.           (set! base (+ base 1))
  203.           (if (= base size)
  204.           (begin
  205.             (set-car! segment 0)
  206.             #t)
  207.           (begin
  208.             (set-car! segment base)
  209.             #f))))))
  210.     (set! angel1 (fmod angle1 (* 2 *pi*)))
  211.     (set! angel2 (fmod angle2 (* 2 *pi*)))
  212.     (fill-segment! (+ center-x
  213.               (* rad1 (sin angle1))
  214.               (* rad2 (- (sin angle2))))
  215.            (+ center-y
  216.               (* rad1 (cos angle1))
  217.               (* rad2 (cos angle2)))
  218.            segment))
  219.  
  220.   ; (set-brush-color! index total-step hue-rate rgb hsv)
  221.   ; (set! drawable-to-erase drawable)
  222.   (define (draw-segment img drawable drawable-to-erase single-drawable?
  223.             segment limit rgb background-color
  224.             stroke-overwrite keep-opacity paint-mode)
  225.     (if (not stroke-overwrite)
  226.     (begin        ; erase crossover region
  227.       (if (< keep-opacity 100) (gimp-brushes-set-opacity 100))
  228.       (if single-drawable?
  229.           (begin
  230.         (gimp-brushes-set-paint-mode NORMAL)
  231.         (gimp-palette-set-foreground background-color)
  232.         (gimp-airbrush drawable-to-erase 100
  233.                    (* 2 limit) (segment-strokes segment))
  234.         (gimp-brushes-set-paint-mode paint-mode))
  235.           (gimp-eraser drawable-to-erase (* 2 limit)
  236.                (segment-strokes segment)))
  237.       (if (< keep-opacity 100) (gimp-brushes-set-opacity keep-opacity))))
  238.     (gimp-palette-set-foreground rgb)
  239.     (gimp-airbrush drawable 100 (* 2 limit) (segment-strokes segment)))
  240.  
  241.   (define (set-brush-color! index max-index hue-rate rgb hsv)
  242.     (if (= 0 hue-rate)
  243.     rgb
  244.     (let* ((max-hue 254)
  245.            (hue (* max-hue (fmod (/ (* index (abs hue-rate)) max-index) 1))))
  246.       (if (< hue-rate 0)
  247.           (set! hue (- max-hue hue)))
  248.       (set-car! hsv hue)
  249.       (hsv-to-rgb hsv rgb)
  250.       rgb)))
  251.  
  252.   (define (trochoid-rotate-gear total-distance img use-this-drawable center-x
  253.                 center-y base-radius wheel-radius pen-pos hue-rate
  254.                 layer-paint-mode stroke-overwrite brush-details)
  255.     (let* ((rad-of-wheel 0)
  256.        (steps-for-circle 100.0)
  257.        (wheel-spin (/ total-distance (abs wheel-radius)))
  258.        (total-step (* wheel-spin steps-for-circle))
  259.        (loop-num (max (* 2 (/ total-distance base-radius))
  260.               (/ total-distance (abs wheel-radius))))
  261.        (steps-for-a-loop (/ total-step loop-num))
  262.        (w2r (/ (abs wheel-radius) base-radius))
  263.        (rad-of-step (/ (* 2.0 *pi*) steps-for-circle))
  264.        (brush-opacity (car (gimp-brushes-get-opacity)))
  265.        (rgb (car (gimp-palette-get-foreground)))
  266.        (drawable use-this-drawable)
  267.        (drawable-to-erase use-this-drawable)
  268.        (paint-mode (car (gimp-brushes-get-paint-mode)))
  269.        (background-color (car (gimp-palette-get-background)))
  270.        (hsv '(0 255 255))
  271.        (index 0)
  272.        (iindex 0)
  273.        (center2wheel (+ base-radius wheel-radius))
  274.        (wheel2pen (* (abs wheel-radius) pen-pos))
  275.        (segment (make-segment
  276.              (if (= 0 hue-rate)
  277.              32
  278.              (max 4 (floor (/ (/ total-step (abs hue-rate)) 255.0))))
  279.              center-x (+ center-y center2wheel wheel2pen))))
  280.       (while (< 0 loop-num)
  281.          (set! iindex 0)
  282.          (if (null? use-this-drawable)
  283.          (begin
  284.            (if drawable (set! drawable-to-erase drawable))
  285.            (set! drawable (car (gimp-layer-copy
  286.                     (or drawable
  287.                         (car (gimp-image-get-active-layer img)))
  288.                     1)))
  289.            (if (not drawable-to-erase) (set! drawable-to-erase drawable))
  290.            (gimp-image-add-layer img drawable 0)
  291.            (gimp-layer-set-mode drawable layer-paint-mode)
  292.            (gimp-layer-set-name drawable
  293.                     (string-append "cricle "
  294.                                (number->string loop-num)))
  295.            (gimp-edit-clear drawable)))
  296.          (while (< iindex steps-for-a-loop) ; draw a circle
  297.             (set! rad-of-wheel (* rad-of-step index))
  298.             (if (update-segment! center-x center-y
  299.                      (* w2r rad-of-wheel) center2wheel
  300.                      rad-of-wheel wheel2pen
  301.                      segment)
  302.             (begin
  303.               (draw-segment img drawable drawable-to-erase use-this-drawable
  304.                     segment (segment-max-size segment)
  305.                     (set-brush-color! index total-step hue-rate rgb hsv)
  306.                     background-color
  307.                     stroke-overwrite brush-opacity paint-mode)
  308.               (set! drawable-to-erase drawable)))
  309.             (set! index (+ index 1))
  310.             (set! iindex (+ iindex 1)))
  311.          (if use-this-drawable (gimp-displays-flush))
  312.          (set! loop-num (- loop-num 1)))
  313.       (while (<= index total-step)
  314.          (set! rad-of-wheel (* rad-of-step index))
  315.          (if (update-segment! center-x center-y
  316.                   (* w2r rad-of-wheel) center2wheel
  317.                   rad-of-wheel wheel2pen
  318.                   segment)
  319.          (begin
  320.            (draw-segment img drawable drawable-to-erase use-this-drawable
  321.                  segment (segment-max-size segment)
  322.                  (set-brush-color! index total-step hue-rate rgb hsv)
  323.                  background-color
  324.                  stroke-overwrite brush-opacity paint-mode)
  325.            (set! drawable-to-erase drawable)))
  326.          (set! index (+ index 1)))
  327.       (if (< 1 (segment-filled-size segment))
  328.       (draw-segment img drawable drawable-to-erase use-this-drawable
  329.             segment (segment-filled-size segment)
  330.             (set-brush-color! index total-step hue-rate rgb hsv)
  331.             background-color
  332.             stroke-overwrite brush-opacity paint-mode))))
  333.   ;; start of script-fu-trochoid
  334.   (let* ((base-radius (floor (abs base-radius-f))) ; to int
  335.      (wheel-radius (floor wheel-radius-f)) ; to int
  336.      (total-step-num (if (or (= 0 base-radius) (= 0 wheel-radius))
  337.                  1
  338.                  (LCM base-radius (abs wheel-radius))))
  339.      (brush-size (gimp-brushes-get-brush))
  340.      (drawable-size (if (or (= 0 base-radius) (= 0 wheel-radius))
  341.                 256
  342.                 (* 2.0 (+ base-radius
  343.                       (max (* 2 wheel-radius) 0)
  344.                       (max (nth 1 brush-size)
  345.                        (nth 2 brush-size))))))
  346.      (img (car (gimp-image-new drawable-size drawable-size RGB)))
  347.      (BG-layer (car (gimp-layer-new img drawable-size drawable-size
  348.                     RGBA_IMAGE "background" 100 NORMAL)))
  349.      (layer-paint-mode 0)
  350.      (the-layer #f)
  351.      (old-paint-mode (car (gimp-brushes-get-paint-mode)))
  352.      (old-brush (car (gimp-brushes-get-brush)))
  353.      (old-rgb (car (gimp-palette-get-foreground))))
  354.     (gimp-brushes-set-brush (car brush-details))
  355.     (gimp-image-undo-disable img)
  356.     (gimp-image-add-layer img BG-layer 0)
  357.     (gimp-edit-fill BG-layer BG-IMAGE-FILL)
  358.     (if (<= 0 erase-before-draw)    ; HDDN FTR (2SLW)
  359.     (begin
  360.       (set! the-layer (car (gimp-layer-new img drawable-size drawable-size
  361.                            RGBA_IMAGE "the curve"
  362.                            100 NORMAL)))
  363.       (gimp-image-add-layer img the-layer 0)
  364.       (if (= NORMAL old-paint-mode)
  365.           (gimp-edit-clear the-layer)
  366.           (gimp-edit-fill the-layer BG-IMAGE-FILL)))
  367.     (begin
  368.       (set! layer-paint-mode (- 1 erase-before-draw))
  369.       (gimp-image-set-active-layer img BG-layer)))
  370.     (gimp-display-new img)
  371.     (gimp-displays-flush)
  372.     (if (or (= base-radius 0) (= wheel-radius 0))
  373.     (gimp-text-fontname img -1 0 0
  374.            "`Base-radius'\n and\n`Rad.;hyp<0<epi'\n require\n non zero values."
  375.            1 1 18 PIXELS "-*-helvetica-*-r-*-*-*-*-*-*-p-*-*-*")
  376.     (trochoid-rotate-gear total-step-num img the-layer
  377.                   (/ drawable-size 2) (/ drawable-size 2)
  378.                   base-radius wheel-radius pen-pos hue-rate
  379.                   layer-paint-mode (= 0 erase-before-draw) brush-details))
  380.     (gimp-palette-set-foreground old-rgb)
  381.     (gimp-brushes-set-brush old-brush)
  382.     (gimp-brushes-set-paint-mode old-paint-mode)
  383.     (gimp-image-undo-enable img)
  384.     (gimp-displays-flush)))
  385.  
  386. (script-fu-register "script-fu-trochoid"
  387.             _"<Toolbox>/Xtns/Script-Fu/Patterns/Trochoid..."
  388.             "Draw Trochoid Curve"
  389.             "Shuji Narazaki <narazaki@InetQ.or.jp>"
  390.             "Shuji Narazaki"
  391.             "1997"
  392.             ""
  393.             SF-ADJUSTMENT _"Base Radius (pixel)" '(40 0 512 1 1 0 0)
  394.             SF-ADJUSTMENT _"Wheel Radius (hypo < 0 < epi)" '(60 0 512 1 1 0 0)
  395.             SF-ADJUSTMENT _"Pen Rad. / Wheel Rad. [0.0:1.0]" '(0.8 0 1 .01 .01 2 0)
  396.             SF-ADJUSTMENT _"Hue Rate" '(1.0 0 1 .01 .01 2 0)
  397.             ; Does erase_before_draw something? I can't see any effect...
  398.             SF-ADJUSTMENT _"Erase before Draw" '(0 0 16 1 10 0 1)
  399.                 SF-BRUSH      _"Use Brush" '("Circle (05)" 1.0 44 2)
  400. )
  401.  
  402. ;;; trochoid.scm ends here
  403.