;; ======================================================================
;; The graphics Language -- From SICP 2.2.4
;; With porting to TurtleSCM (Michael Elhadad / Mar 97)
;; ======================================================================
;; 
;;

;; ======================================================================
;; Supporting ADTs
;; ======================================================================

;; Frames

(define (frame-coord-map frame)
  (lambda (v)
    (add-vect
     (origin-frame frame)
     (add-vect (scale-vect (xcor-vect v)
                           (edge1-frame frame))
               (scale-vect (ycor-vect v)
                           (edge2-frame frame))))))

(define (make-frame origin edge1 edge2)
  (list origin edge1 edge2))

(define (origin-frame frame) (car frame))
(define (edge1-frame frame) (cadr frame))
(define (edge2-frame frame) (caddr frame))

;; Vectors

(define (make-vect x y) (list x y))
(define (xcor-vect v) (car v))
(define (ycor-vect v) (cadr v))
(define (add-vect v1 v2) (make-vect (+ (xcor-vect v1) (xcor-vect v2))
				    (+ (ycor-vect v1) (ycor-vect v2))))
(define (scale-vect s v) (make-vect (* s (xcor-vect v))
				    (* s (ycor-vect v))))
(define (sub-vect v1 v2) (make-vect (- (xcor-vect v1) (xcor-vect v2))
				    (- (ycor-vect v1) (ycor-vect v2))))


;; Segments

(define (make-segment start-point end-point) (list start-point end-point))
(define (start-segment s) (car s))
(define (end-segment s) (cadr s))


;; ======================================================================  
;; Implementation specific support
;; ======================================================================  

;; This is the implementation specific operation
(define (draw-line! v1 v2)
  (move-to! (xcor-vect v1) (ycor-vect v1))
  (draw-to! (xcor-vect v2) (ycor-vect v2)))

;; Plus some support
(define (init-graphics!)
  (graphics-mode!)
  (set-color! 10)    ;; A nice green
  (clear-graphics!))

;; A frame with a 10 dots pixel inside the window
(define (center-frame)
  (make-frame (make-vect 0 0)
	      (make-vect (max-x) 0)
	      (make-vect 0 (max-y))))

;; Test a painter
(define (draw-painter! painter)
  (painter (center-frame)))

;; ======================================================================  
;; Painters
;; ======================================================================  

;; Painter constructor from segments
;; 
(define (segments->painter segment-list)
  (lambda (frame)
    (for-each
     (lambda (segment)
       (draw-line!
        ((frame-coord-map frame) (start-segment segment))
        ((frame-coord-map frame) (end-segment segment))))
     segment-list)))

;; Painter operations
;; Independent of the type of painter

(define (transform-painter painter origin corner1 corner2)
  (lambda (frame)
    (let ((m (frame-coord-map frame)))
      (let ((new-origin (m origin)))
        (painter
         (make-frame new-origin
                     (sub-vect (m corner1) new-origin)
                     (sub-vect (m corner2) new-origin)))))))


(define (flip-vert painter)
  (transform-painter painter
                     (make-vect 0.0 1.0)    ; new origin
                     (make-vect 1.0 1.0)    ; new end of edge1
                     (make-vect 0.0 0.0)))  ; new end of edge2

(define (flip-horiz painter)
  (transform-painter painter
                     (make-vect 1.0 0.0)    ; new origin
                     (make-vect 0.0 0.0)    ; new end of edge1
                     (make-vect 1.0 1.0)))  ; new end of edge2


(define (rotate90 painter)
  (transform-painter painter
                     (make-vect 1.0 0.0)
                     (make-vect 1.0 1.0)
                     (make-vect 0.0 0.0)))


(define (rotate180 painter)
  (transform-painter painter
                     (make-vect 1.0 1.0)
                     (make-vect 0.0 1.0)
                     (make-vect 1.0 0.0)))

(define (beside painter1 painter2)
  (let ((split-point (make-vect 0.5 0.0)))
    (let ((paint-left
           (transform-painter painter1
                              (make-vect 0.0 0.0)
                              split-point
                              (make-vect 0.0 1.0)))
          (paint-right
           (transform-painter painter2
                              split-point
                              (make-vect 1.0 0.0)
                              (make-vect 0.5 1.0))))
      (lambda (frame)
        (paint-left frame)
        (paint-right frame)))))


(define (below painter1 painter2)
  (let ((split-point (make-vect 0.0 0.5)))
    (let ((paint-bottom
           (transform-painter painter1
                              (make-vect 0.0 0.0)
                              (make-vect 1.0 0.0)
                              split-point))
          (paint-top
           (transform-painter painter2
                              split-point
                              (make-vect 1.0 0.5)
                              (make-vect 0.0 1.0))))
      (lambda (frame)
        (paint-top frame)
        (paint-bottom frame)))))


;; ======================================================================
;; Some applications
;; ======================================================================


;; Draw an X in the frame
(define x-painter
  (segments->painter (list
		      (make-segment (make-vect 0.0 0.0)
				    (make-vect 1.0 1.0))
		      (make-segment (make-vect 0.0 1.0)
				    (make-vect 1.0 0.0)))))

;; Draw the outline of the frame
(define outline-painter
  (segments->painter (list
		      (make-segment (make-vect 0.0 0.0)
				    (make-vect 0.0 1.0))
		      (make-segment (make-vect 0.0 1.0)
				    (make-vect 1.0 1.0))
		      (make-segment (make-vect 1.0 1.0)
				    (make-vect 1.0 0.0))
		      (make-segment (make-vect 1.0 0.0)
				    (make-vect 0.0 0.0)))))


;; One diagonal / in frame
(define diag1-painter
  (segments->painter (list
		      (make-segment (make-vect 0.0 0.0)
				    (make-vect 1.0 1.0)))))
  

;; Some higher order combinators

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

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


(define (up-split painter n)
  (if (= n 0)
      painter
      (let ((smaller (up-split painter (- n 1))))
        (below painter (beside smaller smaller)))))
  
(define (corner-split painter n)
  (if (= n 0)
      painter
      (let ((up (up-split painter (- n 1)))
            (right (right-split painter (- n 1))))
        (let ((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 (square-limit painter n)
  (let ((quarter (corner-split painter n)))
    (let ((half (beside (flip-horiz quarter) quarter)))
      (below (flip-vert half) half))))


;; Higher-order operations

(define (square-of-four tl tr bl br)
  (lambda (painter)
    (let ((top (beside (tl painter) (tr painter)))
          (bottom (beside (bl painter) (br painter))))
      (below bottom top))))


(define (flipped-pairs painter)
  (let ((combine4 (square-of-four identity flip-vert
                                  identity flip-vert)))
    (combine4 painter)))

(define (square-limit painter n)
  (let ((combine4 (square-of-four flip-horiz identity
                                  rotate180 flip-vert)))
    (combine4 (corner-split painter n))))