;;; painter.scm
;;; Portions copyright Harold Abelson, Gerald Jay Sussman, Julie Sussman.
;;; Other portions by David Fifield.

;;; This portion of the file is taken directly from the text of
;;; Structure and Interpretation of Computer Programs, Second
;;; Edition. These procedures are publicly available at
;;; http://mitpress.mit.edu/sicp/code/ch2.scm.

(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 (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))))

(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 (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 (segments->painter segment-list)
  (lambda (frame)
    (mapcar
     (lambda (segment)
       (draw-line
	((frame-coord-map frame) (start-segment segment))
	((frame-coord-map frame) (end-segment segment))))
     segment-list)))

(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)
		     (make-vect 1.0 1.0)
		     (make-vect 0.0 0.0)))

(define (shrink-to-upper-right painter)
  (transform-painter painter
		     (make-vect 0.5 0.5)
		     (make-vect 1.0 0.5)
		     (make-vect 0.5 1.0)))

(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 (squash-inwards painter)
  (transform-painter painter
		     (make-vect 0.0 0.0)
		     (make-vect 0.65 0.35)
		     (make-vect 0.35 0.65)))

(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)))))

;;; The remainder of this file comprises code written by David
;;; Fifield. It includes procedures that were left as exercises in the
;;; text and interfaces to the GIMP. For more information see
;;; http://www.bamsoftware.com/hacks/painter/index.html.

;;; This portion of the file is in the public domain.

(define (identity painter)
  painter)

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

(define (split p1 p2)
  (lambda (painter n)
    (if (= n 0)
	painter
	(let ((smaller ((split p1 p2) painter (- n 1))))
	  (p1 painter (p2 smaller smaller))))))

(define (make-vect x y)
  (cons x y))

(define (xcor-vect v)
  (car v))

(define (ycor-vect v)
  (cdr v))

(define (add-vect v1 v2)
  (make-vect (+ (xcor-vect v1) (xcor-vect v2))
	     (+ (ycor-vect v1) (ycor-vect v2))))

(define (sub-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 (origin-frame f)
  (car f))

(define (edge1-frame f)
  (cadr f))

(define (edge2-frame f)
  (caddr f))

(define (make-segment start end)
  (cons start end))

(define (start-segment s)
  (car s))

(define (end-segment s)
  (cdr s))

(define (flip-horiz painter)
  (transform-painter painter
		     (make-vect 1.0 0.0)
		     (make-vect 0.0 0.0)
		     (make-vect 1.0 1.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 (rotate270 painter)
  (transform-painter painter
		     (make-vect 0.0 1.0)
		     (make-vect 0.0 0.0)
		     (make-vect 1.0 0.0)))

(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-bottom frame)
	(paint-top frame)))))

(define outline-painter
  (segments->painter
   (list (make-segment (make-vect 0.0 0.0)
		       (make-vect 1.0 0.0))
	 (make-segment (make-vect 1.0 0.0)
		       (make-vect 1.0 1.0))
	 (make-segment (make-vect 1.0 1.0)
		       (make-vect 0.0 1.0))
	 (make-segment (make-vect 0.0 1.0)
		       (make-vect 0.0 0.0)))))

(define x-painter
  (segments->painter
   (list (make-segment (make-vect 0.0 0.0)
		       (make-vect 1.0 1.0))
	 (make-segment (make-vect 1.0 0.0)
		       (make-vect 0.0 1.0)))))

(define diamond-painter
  (segments->painter
   (list (make-segment (make-vect 0.5 0.0)
		       (make-vect 1.0 0.5))
	 (make-segment (make-vect 1.0 0.5)
		       (make-vect 0.5 1.0))
	 (make-segment (make-vect 0.5 1.0)
		       (make-vect 0.0 0.5))
	 (make-segment (make-vect 0.0 0.5)
		       (make-vect 0.5 0.0)))))

(define wave
  (segments->painter
   (list (make-segment (make-vect 0.00 0.85)
		       (make-vect 0.15 0.60))
	 (make-segment (make-vect 0.15 0.60)
		       (make-vect 0.30 0.65))
	 (make-segment (make-vect 0.30 0.65)
		       (make-vect 0.40 0.65))
	 (make-segment (make-vect 0.40 0.65)
		       (make-vect 0.35 0.85))
	 (make-segment (make-vect 0.35 0.85)
		       (make-vect 0.40 1.00))
	 (make-segment (make-vect 0.60 1.00)
		       (make-vect 0.65 0.85))
	 (make-segment (make-vect 0.65 0.85)
		       (make-vect 0.60 0.65))
	 (make-segment (make-vect 0.60 0.65)
		       (make-vect 0.75 0.65))
	 (make-segment (make-vect 0.75 0.65)
		       (make-vect 1.00 0.35))
	 (make-segment (make-vect 1.00 0.15)
		       (make-vect 0.60 0.45))
	 (make-segment (make-vect 0.60 0.45)
		       (make-vect 0.75 0.00))
	 (make-segment (make-vect 0.60 0.00)
		       (make-vect 0.50 0.30))
	 (make-segment (make-vect 0.50 0.30)
		       (make-vect 0.40 0.00))
	 (make-segment (make-vect 0.25 0.00)
		       (make-vect 0.35 0.50))
	 (make-segment (make-vect 0.35 0.50)
		       (make-vect 0.30 0.60))
	 (make-segment (make-vect 0.30 0.60)
		       (make-vect 0.15 0.40))
	 (make-segment (make-vect 0.15 0.40)
		       (make-vect 0.00 0.65)))))

(define (file->painter filename)
  (let* ((scratch-image
	  (car (gimp-file-load RUN-NONINTERACTIVE filename filename)))
	 (scratch-layer (car (gimp-image-get-active-layer scratch-image))))
    (if (= (car (gimp-drawable-is-rgb scratch-layer)) 0)
	(gimp-convert-rgb scratch-image))
    (gimp-image-clean-all scratch-image)
    (lambda (frame)
      (let* ((v1 (origin-frame frame))
	     (v2 (add-vect v1 (edge1-frame frame)))
	     (v3 (add-vect v1 (edge2-frame frame)))
	     (v4 (add-vect v1 (add-vect (edge1-frame frame)
					(edge2-frame frame))))
	     (layer-id (car (gimp-image-get-active-layer image-id)))
	     (copy-layer (car (gimp-layer-copy scratch-layer 0))))
	(gimp-drawable-set-image copy-layer image-id)
	(gimp-image-add-layer image-id copy-layer -1)
 	(gimp-perspective copy-layer 1
 			  (xcor-vect v3) (ycor-vect v3)
 			  (xcor-vect v4) (ycor-vect v4)
 			  (xcor-vect v1) (ycor-vect v1)
 			  (xcor-vect v2) (ycor-vect v2))
	(gimp-image-merge-down image-id copy-layer EXPAND-AS-NECESSARY)))))
       
(define (draw-line start end)
  (let ((vec (cons-array 4 'double)))
    (aset vec 0 (xcor-vect start))
    (aset vec 1 (ycor-vect start))
    (aset vec 2 (xcor-vect end))
    (aset vec 3 (ycor-vect end))
    (gimp-paintbrush-default
     (car (gimp-image-get-active-layer image-id))
     4
     vec)))

(define (paint painter frame)
  (let* ((v1 (origin-frame frame))
	 (v2 (add-vect v1 (edge1-frame frame)))
	 (v3 (add-vect v1 (edge2-frame frame)))
	 (v4 (add-vect v1 (add-vect (edge1-frame frame)
				    (edge2-frame frame))))
	 (left (min (xcor-vect v1) (xcor-vect v2) (xcor-vect v3) (xcor-vect v4)))
	 (right (max (xcor-vect v1) (xcor-vect v2) (xcor-vect v3) (xcor-vect v4)))
	 (bottom (min (ycor-vect v1) (ycor-vect v2) (ycor-vect v3) (ycor-vect v4)))
	 (top (max (ycor-vect v1) (ycor-vect v2) (ycor-vect v3) (ycor-vect v4)))
	 (img-left (min left 0.0))
	 (img-right (max right 0.0))
	 (img-bottom (min bottom 0.0))
	 (img-top (max top 0.0))
	 (width (- img-right img-left))
	 (height (- img-top img-bottom)))
    (set! image-id (car (gimp-image-new width height RGB)))
    (set! layer-id (car (gimp-layer-new image-id width height RGBA-IMAGE
					"Background" 100 NORMAL-MODE)))
    (gimp-image-undo-disable image-id)
    (gimp-drawable-fill layer-id TRANS-IMAGE-FILL)
    (gimp-image-add-layer image-id layer-id 0)
    (let* ((new-origin (make-vect (- (xcor-vect v1) img-left)
				  (- height
				     (- (ycor-vect v1) img-bottom))))
	   (new-edge1 (make-vect (xcor-vect (edge1-frame frame)) 
				 (- (ycor-vect (edge1-frame frame)))))
	   (new-edge2 (make-vect (xcor-vect (edge2-frame frame))
				 (- (ycor-vect (edge2-frame frame))))))
      (painter (make-frame new-origin new-edge1 new-edge2)))
    (gimp-image-clean-all image-id)
    (gimp-image-undo-enable image-id)
    (gimp-display-new image-id)))

(define default-frame
  (make-frame (make-vect 0.0 0.0)
	      (make-vect 256.0 0.0)
	      (make-vect 0.0 256.0)))