bezier-curve.scm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Simple Scheme 用 Bézier 曲線描画手続き

(define (binomial-coefficients n)
  (if (= 0 n) '(1)
    (let* ((d1 (append (binomial-coefficients (-- n)) '(0))) (d2 (cons 0 d1)))
      (build-list (++ n) (lambda (i) (+ (list-ref d1 i) (list-ref d2 i)))))))

(define (add-bezier-curve scn xs ys color)
  (let* ((n (length xs)) (n-1 (-- n)) (cs (binomial-coefficients n-1))
         (cs_x (build-list n (lambda (i) (* (list-ref cs i) (list-ref xs i)))))
         (cs_y (build-list n (lambda (i) (* (list-ref cs i) (list-ref ys i)))))
         (x_s (lambda (s)
           (let ((t (/ (- 1.0 s) s)))
             (* (expt s n-1) (foldl (lambda (c x) (+ (* x t) c)) 0 cs_x)))))
         (y_s (lambda (s)
           (let ((t (/ (- 1.0 s) s)))
             (* (expt s n-1) (foldl (lambda (c y) (+ (* y t) c)) 0 cs_y))))))
    (letrec ((lp (lambda (s prev-x prev-y scn)
               (if (>= s 1) scn
                 (let* ((s (+ s 1/256)) (x (round (x_s s))) (y (round (y_s s))))
                   (lp s x y (add-line scn prev-x prev-y x y color)))))))
      (lp 0 (first cs_x) (first cs_y) scn))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 使用例。完全シャッフル機械の絵を描く。

;;; 座標の設定
(define top 1.0) (define bottom -1.0) (define left -2.0) (define right 2.0)

(define center-x (/ (image-width  (empty-scene)) 2))
; (empty-scene) のサイズは描画領域のサイズと異なるので、
; 数値を具体的に指定している。
(define center-y (cond ((= center-x 540) 780) ((= center-x 888) 444)
                       (else (/ (image-height (empty-scene)) 2))))

(define mag
  (* 2 (min (/ center-x (- right left)) (/ center-y (- top bottom)))))

(define offset-x (- center-x (* mag 1/2 (+ left right))))
(define offset-y (+ center-y (* mag 1/2 (+ top bottom))))

(define (conv-x x) (+ offset-x (* mag x)))
(define (conv-y y) (- offset-y (* mag y)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define machine-size 16) (define machine-size/2 (/ machine-size 2))
(define iota-size (build-list machine-size (lambda (i) i)))

(define (nth-x-coordinate n) (/ (- n machine-size/2 -1/2) machine-size/2))
(define (nth-dest n)
  (let ((n (* n 2))) (if (>= n machine-size) (- n (-- machine-size)) n)))

;;; 上下に並んだスロットを Bézier 曲線で繋ぐ
(define xs1 (build-list machine-size/2 nth-x-coordinate))
(define xs2 (map (lambda (x1) (- (* 3/2 left) (* 7/4 x1))) xs1))
(set! xs1 (map conv-x (append xs1 (map - (reverse xs1)))))
(set! xs2 (map conv-x (append xs2 (map - (reverse xs2)))))

(define y1 1/3) (define dy (/ (- top y1) machine-size))
(define ys1 (build-list machine-size (lambda (i) y1)))
(define ys2 (build-list machine-size/2 (lambda (i) (+ y1 (* 2 (+ 2 i) dy)))))
(define ys3 (map - ys2)) (define y4 (conv-y (- y1)))
(set! y1 (conv-y y1)) (set! ys2 (map conv-y (append ys2 (reverse ys2))))
(set! ys3 (map conv-y (append ys3 (reverse ys3))))

(define ways-back
  (foldl (lambda (i scn)
           (let ((x1 (list-ref xs1 i)) (x2 (list-ref xs2 i))
                 (y2 (list-ref ys2 i)) (y3 (list-ref ys3 i)))
             (add-bezier-curve scn (list x1 x1 x2 x2 x1 x1)
                               (list y1 y2 y2 y3 y3 y4) "black")))
         (empty-scene) iota-size))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define slot
  (overlay (circle (- (/ mag machine-size) 1) "outline" "black")
           (circle (- (/ mag machine-size) 1) "solid" "white")))
(show-image
  (foldl (lambda (i scn)
           (place-image
             slot (list-ref xs1 (nth-dest i)) y4
             (place-image slot (list-ref xs1 i) y1 
                          (add-line scn (list-ref xs1 i) y1
                                    (list-ref xs1 (nth-dest i)) y4 "black"))))
         ways-back iota-size))