; Drawing fancy curves with higher-order procedures

(require (lib "math.ss"))
(require (lib "graphics.ss" "graphics"))

(open-graphics)

(define size 400)

(define w (open-viewport "FRACTALS" size size))

(define (graphics-draw-line window start-pt end-pt)
  ((draw-line window) (make-posn (* size (posn-x start-pt))
                                 (- size (* size (posn-y start-pt))))
		      (make-posn (* size (posn-x end-pt))
		                 (- size (* size (posn-y end-pt))))))

(define (graphics-draw-pixel window point)
  ((draw-pixel window) (make-posn (* size (posn-x point))
                                  (- size (* size (posn-y point))))))

                               ;Unit-Interval = {x: Sch-Num | 0 <= x <= 1}
                               ;Curve = Unit-interval --> Point

                               ;;SOME CURVES

(define (unit-circle t)
  (make-posn (sin (* 2 pi t))
             (cos (* 2 pi t))))

(define (unit-line t)
  (make-posn t 0))

(define (alternative-unit-circle t)
  (make-posn (sin (* 2 pi (square t)))
             (cos (* 2 pi (square t)))))

                                        ;Curve-Transform = (Curve --> Curve)

                              ;;SOME CURVE-TRANSFORMS


(define (rotate-pi/2 curve)
  (lambda (t)
    (let ((ct (curve t)))
      (make-posn
       (- (posn-y ct))
       (posn-x ct)))))

                           ;;CONSTRUCTORS OF CURVE-TRANSFORMS

;;; TRANSLATE is of type (Sch-Num, Sch-Num --> Curve-Transform)

(define (translate x0 y0)               
  (lambda (curve)
    (lambda (t)
      (let ((ct (curve t)))
        (make-posn (+ x0 (posn-x ct))
                   (+ y0 (posn-y ct)))))))

;;; ROTATE-AROUND-ORIGIN is of type (Sch-Num --> Curve-Transform)

(define (rotate-around-origin theta)
  (let ((cth (cos theta))
        (sth (sin theta)))
    (lambda (curve)
      (lambda (t)
        (let ((ct (curve t)))
          (let ((x (posn-x ct))
                (y (posn-y ct)))
            (make-posn
             (- (* cth x) (* sth y))
             (+ (* sth x) (* cth y)))))))))

(define (scale-x-y a b)
  (lambda (curve)
    (lambda (t)
      (let ((ct (curve t)))
        (make-posn (* a (posn-x ct))
                   (* b (posn-y ct)))))))

(define (scale s)
  (scale-x-y s s))

;;; SQUEEZE-RECTANGULAR-PORTION translates and scales a curve
;;; so the portion of the curve in the rectangle
;;; with corners xlo xhi ylo yhi will appear in a display window
;;; which has x, y coordinates from 0 to 1.
;;; It is of type (Sch-Num,Sch-Num,Sch-Num,Sch-Num --> Curve-Transform).

(define (squeeze-rectangular-portion xlo xhi ylo yhi)
  (compose (scale-x-y (/ 1 (- xhi xlo))
                      (/ 1 (- yhi ylo)))
           (translate (- xlo) (- ylo))))

;;; PUT-IN-STANDARD-POSITION is a Curve-Transform.
;;; A curve is in "standard position" if it starts at (0,0) ends at (1,0).
;;; A curve is PUT-IN-STANDARD-POSITION by rigidly translating it so its
;;; start point is at the origin, then rotating it about the origin to put
;;; its endpoint on the x axis, then scaling it to put the endpoint at (1,0).

(define (put-in-standard-position curve)
  (let* ((start-point (curve 0))
         (curve-started-at-origin
          ((translate (- (posn-x start-point))
                      (- (posn-y start-point)))
           curve))
         (new-end-point (curve-started-at-origin 1))
         (theta (atan (posn-y new-end-point) (posn-x new-end-point)))
         (curve-ended-at-x-axis
          ((rotate-around-origin (- theta)) curve-started-at-origin))
         (end-point-on-x-axis (posn-x (curve-ended-at-x-axis 1))))
    ((scale (/ 1 end-point-on-x-axis)) curve-ended-at-x-axis)))

                                ;Binary-transform = (Curve,Curve --> Curve)

;;; CONNECT-RIGIDLY makes a curve consisting of curve1 followed by curve2.

(define (connect-rigidly curve1 curve2)
  (lambda (t)
    (if (< t (/ 1 2))
	(curve1 (* 2 t))
	(curve2 (- (* 2 t) 1)))))

;;; CONNECT-ENDS makes a curve consisting of curve1 followed by
;;;  a copy of curve2 starting at the end of curve1

;;;(define (connect-ends curve1 curve2) ...)

                          ;;FRACTAL CURVES

;;; GOSPERIZE is a Curve-Transform

(define (gosperize curve)
  (let ((scaled-curve ((scale (/ (sqrt 2) 2)) curve)))
    (connect-rigidly ((rotate-around-origin (/ pi 4)) scaled-curve)
                     ((translate .5 .5)
                      ((rotate-around-origin (/ (- pi) 4)) scaled-curve)))))


;;; GOSPER-CURVE is of type (Sch-Num --> Curve)

(define (gosper-curve level)
  ((repeated gosperize level) unit-line))

                      ;;DRAWING GOSPER CURVES

(define (show-connected-gosper level)
  ((draw-connected w 200)
   ((squeeze-rectangular-portion -.5 1.5 -.5 1.5)
    (gosper-curve level))))

                      ;;PARAMETERIZED GOSPER

;;; PARAM-GOSPER is of type ((Sch-Num,(Int --> Sch-Num)) --> Curve)

(define (param-gosper level angle-at)
  (if (= level 0)
      unit-line
      ((param-gosperize (angle-at level))
       (param-gosper (- level 1) angle-at))))

(define (param-gosperize theta)
  (lambda (curve)
    (let ((scale-factor (/ (/ 1 (cos theta)) 2)))
      (let ((scaled-curve ((scale scale-factor) curve)))
        (connect-rigidly ((rotate-around-origin theta) scaled-curve)
                         ((translate .5 (* (sin theta) scale-factor))
                          ((rotate-around-origin (- theta)) scaled-curve)))))))

;******************************************************************************
; Some Utility functions



(define (compose f g)
  (lambda (x)
    (f (g x))))

(define (identity t) t)

(define (repeated f n)
  (if (= n 0)
      identity
      (compose f (repeated f (- n 1)))))

(define (square x) (* x x))

(define (draw-connected window n)
  (let ((1/n (/ 1 n)))
    (lambda (curve)
      (define (iter p-old count)
        (let ((t (* count 1/n)))
          (let ((p-new (curve t)))
              (graphics-draw-line window p-old p-new)
              (if (>= count n)
                  'done
                  (iter p-new (+ count 1))))))
      ((clear-viewport window))
      (let ((c0 (curve 0)))
        (iter c0 1)))))

(define (draw-points-on window n)
  (let ((1/n (/ 1 n)))
    (lambda (curve)
      (define (iter p-old count)
        (let ((t (* count 1/n)))
          (let ((p-new (curve t)))
              (graphics-draw-pixel window p-new)
              (if (>= count n)
                  'done
                  (iter p-new (+ count 1))))))
      ((clear-viewport window))
      (let ((c0 (curve 0)))
        (graphics-draw-pixel window c0)
        (iter c0 1)))))