(define (mathgraph++ g f xstep xmax ymax)
  ; g グラフィックスデバイス,
  ; f 関数, xstep xの刻み, xmax xの最大値, ymax yの最大値
  ; （面倒なので）原点を中心に描く
  (do ((x0 (- 0 xmax) (+ x0 xstep))
       (x1 (- xstep xmax) (+ x1 xstep)))
      ((>= x0 xmax) #f)
    (graphics-draw-line g (/ x0 xmax) (/ (f x0) ymax)
			  (/ x1 xmax) (/ (f x1) ymax))))

       

(define (mathgraph g f xstep xmax ymax)
  ; g グラフィックスデバイス,
  ; f 関数, xstep xの刻み, xmax xの最大値, ymax yの最大値
  ; （面倒なので）原点を中心に描く
  (do ((x0 (- 0 xmax) (+ x0 xstep)))
      ((>= x0 xmax) #f)
    (graphics-draw-point g (/ x0 xmax) (/ (f x0) ymax))))


(define (scale f w h)
  ; fのグラフを幅方向に 1/w倍、高さ方向に 1/h倍する。
  (lambda (x) (/ (f (* x w)) h)))


(define (transform f dx dy)
  ; fのグラフを x方向に dx、y方向に dyだけ平行移動する。
  (lambda (x) (+ (f (- x dx)) dy))) 

(define (sigma fs)
  ; 関数のリスト fsのシグマ
  (if (null? fs)
      (lambda (x) 0)	; 定数関数
    (lambda (x) (+ ((car fs) x) ((sigma (cdr fs)) x)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define PI 3.1416)
(define PI_2 (/ PI 2))

; 座標の基本演算
(define (make-vect x y) (cons x (cons y '())))
(define (x-cor-vect p) (car p))
(define (y-cor-vect p) (car (cdr p)))

(define (add-vect p0 p1)
  (make-vect (+ (x-cor-vect p0) (x-cor-vect p1))
	     (+ (y-cor-vect p0) (y-cor-vect p1))))

(define (sub-vect p0 p1)
  (make-vect (- (x-cor-vect p0) (x-cor-vect p1))
	     (- (y-cor-vect p0) (y-cor-vect p1))))

(define (scale-vect c p)
  (make-vect (* c (x-cor-vect p)) (* c (y-cor-vect p))))

; フレーム
(define (make-frame g o u v)  (cons g (cons o (cons u (cons v '())))))
(define (graphics-device-frame frame) (nth frame 0))
(define (origin-frame frame) (nth frame 1))
(define (edge1-frame frame) (nth frame 2))
(define (edge2-frame frame) (nth frame 3))

; 座標変換
(define (frame-coord-map frame)
  (lambda (p)
    (let* ((x (x-cor-vect p)) (y (y-cor-vect p))
	   (o (origin-frame frame))
	   (u (edge1-frame frame))
	   (v (edge2-frame frame)))
      (add-vect o (add-vect (scale-vect x u) (scale-vect y v))))))
	   
; frame用のプリミティブ描画関数
(define (frame-draw-point x y)
  (lambda (frame)
    (let ((p ((frame-coord-map frame) (make-vect x y)))
	  (x_ (x-cor-vect p))
	  (y_ (y-cor-vect p)))
      (graphics-draw-point (graphics-device-frame frame) x_ y_))))

(define (frame-erase-point x y)
  (lambda (frame)
    (let* ((p ((frame-coord-map frame) (make-vect x y)))
	   (x_ (x-cor-vect p))
	   (y_ (y-cor-vect p)))
    (graphics-erase-point (graphics-device-frame frame) x_ y_))))

(define (frame-draw-line x1 y1 x2 y2)
  (lambda (frame) 
    (let* ((f (frame-coord-map frame))
	   (p1 (f (make-vect x1 y1)))
	   (p2 (f (make-vect x2 y2)))
	   (x1_ (x-cor-vect p1)) (y1_ (y-cor-vect p1))
	   (x2_ (x-cor-vect p2)) (y2_ (y-cor-vect p2)))
      (graphics-draw-line (graphics-device-frame frame) x1_ y1_ x2_ y2_))))

(define (frame-draw-text x y string)
  (lambda (frame)
    (let* ((p ((frame-coord-map frame) (make-vect x1 y1)))
	   (x_ (x-cor-vect p)) (y_ (y-cor-vect p)))
      (graphics-draw-string (graphics-device-frame frame) x_ y_ string))))


; pは (x_1 y_1 x_2 y_2 ... x_n y_n)の形のリスト
(define ((frame-coord-map-long frame) p)
    (if (null? p)
	p
    (let* ((x (car p)) (y (cadr p))
	   (o (origin-frame frame))
	   (u (edge1-frame frame))
	   (v (edge2-frame frame)))
      (append (add-vect o (add-vect (scale-vect x u) (scale-vect y v)))
	      ((frame-coord-map-long frame) (cddr p))))))

(define (frame-fill-polygon points)
  (lambda (frame)
    (let ((points_ (list->vector
		    ((frame-coord-map-long frame) (vector->list points)))))
      (graphics-operation (graphics-device-frame frame)
			  'fill-polygon points_))))

(define (default-frame g)
  (make-frame g (make-vect 0 0) (make-vect 1 0) (make-vect 0 1)))

(define (run-painter g painter)
  (painter (default-frame g)))

(define (null-painter frame) #f)	; 何もしないぺインタ

(define (frame-ngon x y r t n)
  (lambda (frame)
    (do ((delta (/ (* 2 PI) n) delta)
	 (i 0 (+ i 1))
	 (theta t (+ theta delta)))
	((>= i n) #f)
      ((frame-draw-line (+ x (* r (cos theta))) (+ y (* r (sin theta)))
			(+ x (* r (cos (+ theta delta))))
			(+ y (* r (sin (+ theta delta))))) frame))))

(define (frame-arc x y r t1 t2 n)
  (lambda (f)
    (do ((delta (/ (* 2 PI) n) delta)
	 (i 0 (+ i 1))
	 (theta t1 (+ theta delta)))
	((>= theta t2) #f)
      ((frame-draw-line (+ x (* r (cos theta))) (+ y (* r (sin theta)))
			(+ x (* r (cos (+ theta delta))))
			(+ y (* r (sin (+ theta delta))))) f))))


; painterの座標変換
(define (transform-painter painter o u v)
  (lambda (frame)
    (let* ((m (frame-coord-map frame))
	   (o1 (m o))
	   (u1 (sub-vect (m (add-vect u o)) o1))
	   (v1 (sub-vect (m (add-vect v o)) o1)))
      (painter (make-frame (graphics-device-frame frame) o1 u1 v1)))))

; painterに関する基本的演算
(define (flip-vert painter)
  (transform-painter painter (make-vect 0 0) (make-vect 1 0) (make-vect 0 -1)))
      
(define (flip-horiz painter)
  (transform-painter painter (make-vect 0 0) (make-vect -1 0) (make-vect 0 1)))
      
(define (rotate90 painter)
  (transform-painter painter (make-vect 0 0) (make-vect 0 1) (make-vect -1 0)))

(define (rotate270 painter)
  (transform-painter painter (make-vect 0 0) (make-vect 0 -1) (make-vect 1 0)))

(define (beside painter1 painter2)
  (let ((left  (transform-painter painter1 (make-vect -0.5 0)
				  (make-vect 0.5 0) (make-vect 0 1)))
	(right (transform-painter painter2  (make-vect 0.5 0)
				  (make-vect 0.5 0) (make-vect 0 1))))
    (lambda (frame)
      (left frame) (right frame))))

(define (below painter1 painter2)
  (let ((up   (transform-painter painter2 (make-vect 0  0.5)
				 (make-vect 1 0) (make-vect 0 0.5)))
	(down (transform-painter painter1 (make-vect 0 -0.5)
				 (make-vect 1 0) (make-vect 0 0.5))))
    (lambda (frame)
      (up frame) (down frame))))

; 再帰的図形
(define (right-split painter n)
  (if (= n 0)
      null-painter
    (let ((smaller (right-split painter (- n 1))))
      (beside painter (below smaller smaller)))))

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

(define (corner-split painter n)
  (if (= n 0)
      null-painter
    (let* ((up (up-split painter (- n 1)))
	   (right (right-split painter (- n 1)))
	   (top-left (beside up up))
	   (bottom-right (below right right))
	   (corner (corner-split painter (- n 1))))
      (beside (below painter top-left)
	      (below bottom-right corner)))))

(define (spiral painter n)
  (if (= n 0)
      null-painter
    (let ((left (rotate90 (spiral painter (- n 1)))))
      (beside left painter))))


; 黄金比らせん
(define golden (/ (- (sqrt 5) 1) 2))

(define (golden-beside painter1 painter2)
  (let ((left  (transform-painter painter1 (make-vect (- golden)  0)
				           (make-vect (- 1 golden) 0)
					   (make-vect 0 1)))
	(right (transform-painter painter2 (make-vect (- 1 golden) 0)
				           (make-vect golden 0)
					   (make-vect 0 1))))
    (lambda (frame)
      (left frame)
      (right frame))))
  
(define (golden-transform painter)
  (transform-painter painter (make-vect 0 0) (make-vect 1 0)
		     (make-vect 0 golden)))

(define (golden-spiral painter n)
  (if (= n 0)
      null-painter
    (let ((left (rotate90 (golden-spiral painter (- n 1)))))
      (golden-beside left painter))))


; 描画例
(define (frame-star x y r t)
  (lambda (frame)
    (do ((delta (/ (* 2 PI) 5) delta)
       (i 0 (+ i 1))
       (theta t (+ theta delta)))
      ((>= i 5) #f)
      ((frame-draw-line
                (+ x (* r (cos theta))) (+ y (* r (sin theta)))
		(+ x (* r (cos (+ theta delta delta))))
		(+ y (* r (sin (+ theta delta delta))))) frame))))

(define star
  (lambda (frame)
    (do ((delta (/ (* 2 PI) 5) delta)
       (i 0 (+ i 1))
       (theta PI_2 (+ theta delta)))
      ((>= i 5) #f)
      ((frame-draw-line
                (cos theta) (sin theta)
                (cos (+ theta delta delta)) (sin (+ theta delta delta)))
                frame))))


(define star4
  (below (beside (flip-vert star) (rotate270 star))
	 (beside (rotate90 star) star)))
(define star-split (corner-split star 4))
(define golden-star (golden-transform (golden-spiral star 10)))


(define diagonal-line (frame-draw-line 1 -1 -1 1))
(define diagonal-spiral (transform-painter (spiral diagonal-line 10)
					   (make-vect 0 0) (make-vect 1 0)
					   (make-vect 0 (/ (sqrt 2) 2))))

(define quater-arc (frame-arc -1 -1 2 0 PI_2 32))
(define golden-arc (golden-transform (golden-spiral quater-arc 6)))

(define test-all (beside (below star-split diagonal-spiral)
			 (below golden-arc star4)))


(define (xarrow frame)
  ((frame-draw-line 0 0 1 0) frame)
  ((frame-fill-polygon #(1 0 0.9 0.05 0.9 -0.05)) frame))

(define yarrow (rotate90 xarrow))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (map f xs)
        (if (null? xs)
            xs
            (cons (f (car xs)) (map f (cdr xs)))))

(define (filter p xs)
        (if (null? xs) 
            xs
            (if (p (car xs))
                (cons (car xs) (filter p (cdr xs)))
                (filter p (cdr xs)))))

(define (iterate a f p)
        (if (p a) 
            '()
            (cons a (iterate (f a) f p))))                

(define (2-to n)
        (iterate 2 (lambda (x) (+ x 1))
                   (lambda (x) (> x n))))

(define (non-zero? n) (not (zero? n)))
(define (sieve xs)
        (let ((p (lambda (x) (non-zero? (modulo x (car xs))))))
             (filter p xs)))

(define (prime-to n)
        (map car (iterate (2-to n) sieve null?)))