picture.scm

;; Standard frame
(define frm1 (make-frame (make-vect 0.0 0.0)
                         (make-vect 1.0 0.0)
                         (make-vect 0.0 1.0)))

;; Shearing frame
(define frm2 (make-frame (make-vect 0.0 0.0)
                         (make-vect 0.66 0.33)
                         (make-vect 0.33 0.66)))

;; Compress to left
(define frm3 (make-frame (make-vect 0.0 0.0)
                         (make-vect 0.5 0.0)
                         (make-vect 0.0 1.0)))

;; Compress to bottom
(define frm4 (make-frame (make-vect 0.0 0.0)
                         (make-vect 1.0 0.0)
                         (make-vect 0.0 0.5)))

(define (up-split painter n)
 (if (= n 0)
  painter
  (let ((smaller (up-split painter (- n 1))))
    (below painter (beside smaller smaller)))))

(define (right-split painter n)
 (if (= n 0)
  painter
  (let ((smaller
         (right-split painter (- n 1))))
    (beside painter (below smaller smaller)))))

(define (left-split painter n)
 (flip-horiz (right-split painter n)))

(define (corner-split painter n)
 (if (= n 0)
  painter
  (let ((up (up-split painter (- n 1)))
        (right (right-split painter (- n 1)))
        (corner (corner-split painter (- n 1))))
   (beside (below painter (beside up up)) (below (below right right) corner)))))

(define (flipped-pairs painter)
 (let ((flip (flip-vert painter)))
   (below  (beside (flip-horiz flip) flip) (beside (flip-horiz painter) painter))))

(define (square-limit painter n)
 (let ((up-right (corner-split painter n)))
   (let ((up-left (flip-horiz up-right))
         (down-right (flip-vert up-right))
         (down-left (flip-vert (flip-horiz up-right))))
     (beside (below down-left up-left) (below down-right up-right)))))

;; Seychelles Painter
(define (seychelles frame)
 (begin
  (set-color #x007A3D)
  ((vertexes->painter
    (list (make-vect 0.0 0.0)
          (make-vect 1.0 0.0)
          (make-vect 1.0 0.33))
    #t ;; fill inside the polygon?
    ) frame)
  (set-color #xFFFFFF)
  ((vertexes->painter
    (list (make-vect 0.0 0.0)
          (make-vect 1.0 0.67)
          (make-vect 1.0 0.33))
    #t ;; fill inside the polygon?
    ) frame)
  (set-color #xD62828)
   ((vertexes->painter
    (list (make-vect 0.0 0.0)
          (make-vect 1.0 0.67)
          (make-vect 1.0 1.0)
          (make-vect 0.67 1.0))
    #t ;; fill inside the polygon?
    ) frame)
   (set-color #xFCD856)
    ((vertexes->painter
    (list (make-vect 0.0 0.0)
          (make-vect 0.33 1.0)
          (make-vect 0.67 1.0))
    #t ;; fill inside the polygon?
    ) frame)
    (set-color #x003F87)
    ((vertexes->painter
       (list (make-vect 0.0 0.0)
             (make-vect 0.0 1.0)
             (make-vect 0.33 1.0))
    #t ;; fill inside the polygon?
    ) frame)))

;; Painter generated from seychelles
(define s1
   (let ((up-right (flip-horiz seychelles)))
   (let ((up-left (flip-horiz up-right))
         (down-right (flip-vert up-right))
         (down-left (flip-vert (flip-horiz up-right))))
     (beside (below down-left up-left) (below down-right up-right)))))

;; Hilbert curve
; 直線上の2点をa:bに内分する点
(define (in-div a b x y)
 (/ (+ (* b x) (* a y)) (+ a b)))

(define (but-last ls)
 (reverse (cdr (reverse ls))))

(define (vectors->segments vector-list)
 (map cons (but-last vector-list) (cdr vector-list)))

(define rules '((a . (d a a b)) (b . (c b b a)) (c . (b c c d)) (d . (a d d c))))
(define zero-rules '((a . (0 1 2 3)) (b . (2 1 0 3)) (c . (2 3 0 1)) (d . (0 3 2 1))))
(define (look-up type dic) 
 (cond ((null? dic) #f)
  ((eq? type (caar dic)) (cdar dic))
  (else (look-up type (cdr dic)))))

(define (hilbert-vectors type p0 q0 p1 q1 n) 
   (let ((xl (in-div 1 3 p0 p1))
         (yl (in-div 1 3 q0 q1))
         (xm (in-div 1 1 p0 p1))
         (ym (in-div 1 1 q0 q1))
         (xr (in-div 3 1 p0 p1))
         (yr (in-div 3 1 q0 q1)))
    (let ((zero-rule (look-up type zero-rules)))
      (if (= n 0) 
        (map (lambda (num) (cond ((= num 0) (make-vect xr yr))
                                 ((= num 1) (make-vect xl yr))
                                 ((= num 2) (make-vect xl yl))
                                 ((= num 3) (make-vect xr yl)))) zero-rule)
        (letrec ((rule (look-up type rules))
                 (appendh (lambda (r zr) 
                            (if (null? r) '()
                              (append (cond ((= (car zr) 0) (hilbert-vectors (car r) xm ym p1 q1 (- n 1)))
                                        ((= (car zr) 1) (hilbert-vectors (car r) p0 ym xm q1 (- n 1)))
                                        ((= (car zr) 2) (hilbert-vectors (car r) p0 q0 xm ym (- n 1)))
                                        ((= (car zr) 3) (hilbert-vectors (car r) xm q0 p1 ym (- n 1))))
                                      (appendh (cdr r) (cdr zr)))))))
          (appendh rule zero-rule))))))

(define (hilbert n)
 (segments->painter (vectors->segments (hilbert-vectors 'a 0.0 0.0 1.0 1.0 n))))
(define (hilbert2 t n)
 (segments->painter (vectors->segments (hilbert-vectors t 0.0 0.0 1.0 1.0 n))))


;; Julia Set
;;
; Complex
(define (square x) (* x x))
(define (make-complex a b) (cons a b))
(define (real-part z) (car z))
(define (imag-part z) (cdr z))
(define (add-complex z1 z2) 
  (let ((a (real-part z1)) (b (imag-part z1)) (c (real-part z2)) (d (imag-part z2)))
    (make-complex (+ a c) (+ b d))))
(define (square-complex z) 
  (let ((a (real-part z)) (b (imag-part z)))
    (make-complex (- (square a) (square b)) (* 2 a b))))
(define (abs-complex z) 
  (+ (square (real-part z)) (square (imag-part z))))

(define (elem n list) 
  (if (= n 0) (car list)
    (elem (- n 1) (cdr list))))

(define color '(#xff0000 #xffc0cb #xff00ff #x0000ff #x00ffff #x00ff00 #xffff00 #x808080))

(define (julia c)
  (define (converge z0 count) 
   (define (iter z n)
     (if (= n count) -1
       (let* ((f (lambda (x) (add-complex (square-complex x) c))) (next (f z)))
         (if (> (abs-complex next) 4.0) n
           (iter next (+ n 1))))))
   (iter z0 0))
  (define (j z)
    (let ((n (converge (add-complex z (make-complex -0.5 -0.5)) 100)))
      (if (= n -1) #xffffff
        (elem (remainder n (length color)) color))))
  (procedure->painter j))