ifs.scm

;
; IFS (Simple Scheme 用)
;

;; C-曲線
(define top 1.2) (define bottom -1.0) (define left -1.5) (define right 1.5)
(define affine-transformations
  '(((1/2  1/2 -1/2 1/2) (-1/2 0))
    ((1/2 -1/2  1/2 1/2) ( 1/2 0))))

;; ドラゴンカーブ
; (define top 2.0) (define bottom -1.0) (define left -1.0) (define right 2.0)
; (define affine-transformations
;   '(((-1/2 -1/2 1/2 -1/2) (1/2  1/2))
;     (( 1/2 -1/2 1/2  1/2) (1/2 -1/2))))

;; シダ
; (define top 10.0) (define bottom 0.0) (define left -4.0) (define right 5.0)
; (define affine-transformations
;   '((( 0     0     0    0.16) (0 0))
;     (( 0.85  0.04 -0.04 0.85) (0 1.6))
;     (( 0.2  -0.26  0.23 0.22) (0 1.6))
;     ((-0.15  0.28  0.26 0.24) (0 0.44))))

;;「次はもう少し現実的な樹木のデータである. 最初の二つの変換が幹に当たるので,
;; 最近の4回の変換にこのどちらかを使ったなら茶色に, そうでなければ緑色にする
;; と木らしくなるという.（奥村晴彦『C言語による最新アルゴリズム事典』p.248）」
;; のデータ。色分け版も下にある。
; (define top 2.0) (define bottom 0.0) (define left -1.0) (define right 1.0)
; (define affine-transformations
;   '(((0.05  0.0   0.0   0.6 ) (0.0 0.0))
;     ((0.05  0.0   0.0  -0.5 ) (0.0 1.0))
;     ((0.46 -0.32  0.39  0.38) (0.0 0.6))
;     ((0.47 -0.15  0.17  0.42) (0.0 1.1))
;     ((0.43  0.28 -0.25  0.45) (0.0 1.0))
;     ((0.42  0.26 -0.35  0.31) (0.0 0.7))))

;;; 変換を、画面の座標系に適用できるように書き換える。;;;;;;;;;;;;;;;;;;;;;;;;;;
(define center-x (/ (image-width (empty-scene)) 2.0))                          ;
(define center-y (/ (* (image-height (empty-scene)) 65.0) 148))                ;
                                                                               ;
(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  get-a11        first    ) (define (get-a12 a) (- (second a)))         ;
(define (get-a21 a) (- (third a))) (define  get-a22        fourth    )         ;
                                                                               ;
(define (conv-const a b)                                                       ;
  (list (+ (* (- 1.0 (get-a11 a)) offset-x) (* (get-a12 a) (- offset-y))       ;
           (* mag (first b)))                                                  ;
        (- (* (- 1.0 (get-a22 a)) offset-y) (* (get-a21 a) offset-x)           ;
           (* mag (second b)))))                                               ;
                                                                               ;
(define ts                                                                     ; 
  (map (lambda (t)                                                             ; 
         (let* ((a (car t)) (b (conv-const (car t) (cadr t)))                  ; 
                (a11 (get-a11 a)) (a12 (get-a12 a))                            ; 
                (a21 (get-a21 a)) (a22 (get-a22 a))                            ; 
                (b1 (first b)) (b2 (second b)))                                ; 
           (lambda (v)                                                         ; 
             (list (+ (* a11 (first v)) (* a12 (second v)) b1)                 ; 
                   (+ (* a21 (first v)) (* a22 (second v)) b2)))))             ; 
       affine-transformations))                                                ; 

;; 変換後の領域の面積に比例する確率で変換を選ぶための表
(define probability-table
  (let* ((abs-det (lambda (a)
                    (abs (- (* (get-a11 a) (get-a22 a))
                            (* (get-a12 a) (get-a21 a))))))
         (dets (map (lambda (t) (abs-det (car t))) affine-transformations))
         (s (foldl + 0.0 dets)) (len (length ts)))
    (foldr append '()
           (build-list
             (length dets)
             (lambda (i)
               (let ((det (list-ref dets i)))
                 (build-list
                   (let ((p (/ det s)))
                     (if (<= p (/ 1/25 len)) 1 (round (* 25 len p))))
                   (lambda (j) i))))))))

(define random-index
  (let ((len (length probability-table)))
    (lambda () (list-ref probability-table (random len)))))

(define (add-dot scn x y color)
  (place-image (rectangle 1 1 "solid" color) x y scn))

(define (warm-up n)
  (if (<= n 0) '(0 0) ((list-ref ts (random-index)) (warm-up (-- n)))))

(letrec ((lp (lambda (i v scn)
           (if (>= i 500000) (show-image scn)
             (lp (++ i) ((list-ref ts (random-index)) v)
                 (add-dot scn (first v) (second v) "black"))))))
  (lp 0 (warm-up 10) (empty-scene)))

;; 「もう少し現実的な樹木のデータ」のための色分け版。
;; 「最近の4回の変換」は6回のほうが木らしくなると思ったのでそうしてある。
; (letrec ((lp (lambda (i v scn flg)
;            (if (>= i 500000) (show-image scn)
;              (let* ((idx (random-index)) (flg (if (< idx 2) 6 (-- flg))))
;                (lp (++ i) ((list-ref ts idx) v)
;                    (add-dot scn (first v) (second v)
;                             (if (<= flg 0) "green" "brown"))
;                    flg))))))
;   (lp 0 (warm-up 10) (empty-scene) 0))