;; This file defines the functional graphics procedures assumed by the textbook
;; Concrete Abstractions: An Introduction to Computer Science Using Scheme
;; by Max Hailperin, Barbara Kaiser, and Karl Knight.
;;
;; This version is specifically for use with Chez Scheme version 6.0 with
;; SWL version 0.9.
;;
;; This file defines all the graphics procedures assumed in the textbook,
;; plus some extensions:
;;  (1) The line and filled-triangle procedures can optionally be
;;      given one or two additional arguments beyond those described
;;      in the book.  If one is given, it specifies the width and
;;      height of the image, while if two are given, the first
;;      specifies the width and the second the height.  In either
;;      case, the unit of measure is the pixel.  If no size is
;;      specified, the width and height are taken as the value of
;;      default-image-size. This is defined below as 60, but this can
;;      be redefined if you want images consistently bigger or
;;      smaller.
;;  (2) Overlay and stack are not restricted to two arguments, but rather
;;      can take one or more.
;;  (3) There is a resize-image procedure that takes as arguments an image
;;      and optionally one or two integers to specify width and height.
;;      It returns a new image that is the specified size (or default size)
;;      produced by suitably stretching or shrinking the provided image.
;;  (4) There is a mirror-image procedure that takes an image as argument.
;;      Like quarter-turn-right or invert, this takes an image and makes
;;      another, related image.  In the case of mirror-image, the new image
;;      is the same size as the original, and is formed by flipping the
;;      original image around a vertical axis, as though it were viewed in a
;;      mirror.
;;
;; This file written by Max Hailperin <max@gustavus.edu>.
;;
;; Revision 1.2 as of 1999/06/16 01:00:00

(define default-image-size 100)

(define invert #f)
(define stack #f)
(define quarter-turn-right #f)
(define mirror-image #f)
(define overlay #f)
(define resize-image #f)
(define line #f)
(define filled-triangle #f)

(let ((normal-waiter-write (waiter-write))
      ;; protect against redefinition of show by chapter 9 code
      (show (if (top-level-bound? 'swl-show)
                swl-show
                show)))
  
  (define-record image
    ((immutable width) (immutable height) (immutable procedure)))
  
  (define (flesh-out-image-size image-size)
    (cond ((null? image-size)
           (list default-image-size default-image-size))
          ((null? (cdr image-size))
           (if (exact-integer? (car image-size))
               (list (car image-size) (car image-size))
               (error "Image size not exact integer" (car image-size))))
          ((null? (cddr image-size))
           (cond ((not (exact-integer? (car image-size)))
                  (error "Image width not exact integer" (car image-size)))
                 ((not (exact-integer? (cadr image-size)))
                  (error "Image height not exact integer" (cadr image-size)))
                 (else
                   image-size)))
          (else (error "Too many inputs, up to two can be image size"
                       image-size))))
  
  (define (exact-integer? x)
    (and (number? x)
         (exact? x)
         (integer? x)))
  
  (define draw ; returns the window title after drawing
    (let ((counter 0)
          (make-size-legal
            (lambda (size)
              ; to do: maybe impose min and max size
              (inexact->exact (round size)))))
      (lambda (image)
        (if (not (image? image))
            (error "draw: input not an image" image)
            (let ((w (make-size-legal (image-width image)))
                  (h (make-size-legal (image-height image))))
              (set! counter (add1 counter))
              (let* ((title (string-append "Img" (number->string counter)))
                     (top (create <toplevel> with (title: title)))
                     (win (create <canvas> top with (width: w) (height: h)
                                  (background-color:
                                   (make <rgb> 255 255 255)))))
                (show win)
                ((image-procedure image) (lambda (p)
                                           (list (* (+ 1. (car p)) (/ w 2.))
                                                 (* (- 1. (cadr p)) (/ h 2.))))
                 win
                 (make <rgb> 0 0 0)
                 (make <rgb> 255 255 255))
                title))))))
  
  (set!
    invert
    (lambda (image)
      (if (not (image? image))
          (error "invert: input not an image" image)
          (make-image (image-width image) (image-height image)
                      (lambda (transform win color other-color)
                        (let ((p0 (transform '(-1 -1)))
                              (p1 (transform '(1 1))))
                          (create <rectangle> win
                                  (car p0) (cadr p0)
                                  (car p1) (cadr p1)
                                  with
                                  (fill-color: color)
                                  (outline-color: color)
                                  (line-thickness: 0))
                          ((image-procedure image) transform win
                           other-color color)))))))
  
  (set!
    stack
    (lambda (top . rest)
      (define (stack2 top bottom)
        (cond
          ((not (image? top))
           (error "stack: input not an image" top))
          ((not (image? bottom))
           (error "stack: input not an image" bottom))
          ((not (= (image-width top) (image-width bottom)))
           (error "stack: inputs not of equal widths" top bottom))
          (else
            (let ((h (+ (image-height top) (image-height bottom))))
              (let ((top-scale (/ (image-height top) h))
                    (bottom-scale (/ (image-height bottom) h)))
                (let ((top-offset bottom-scale)
                      (bottom-offset (- top-scale)))
                  (make-image (image-width top) h
                              (lambda (transform win color other-color)
                                ((image-procedure top)
                                 (lambda (p)
                                   (let ((x (car p))
                                         (y (cadr p)))
                                     (transform (list x (+ (* top-scale y)
                                                           top-offset)))))
                                 win color other-color)
                                ((image-procedure bottom)
                                 (lambda (p)
                                   (let ((x (car p))
                                         (y (cadr p)))
                                     (transform (list x (+ (* bottom-scale y)
                                                           bottom-offset)))))
                                 win color other-color)))))))))
      (let loop ((image top)
                 (images rest))
        (if (null? images)
            image
            (loop (stack2 image (car images)) (cdr images))))))
  
  (set!
    quarter-turn-right
    (lambda (image)
      (if (not (image? image))
          (error "quarter-turn-right: input not an image" image)
          (make-image (image-height image) (image-width image)
                      (lambda (transform win color other-color)
                        ((image-procedure image)
                         (lambda (p)
                           (let ((x (car p))
                                 (y (car (cdr p))))
                             (transform (list y (- x)))))
                         win color other-color))))))
  
  (set!
    mirror-image
    (lambda (image)
      (if (not (image? image))
          (error "mirror-image: input not an image" image)
          (make-image (image-width image) (image-height image)
                      (lambda (transform win color other-color)
                        ((image-procedure image)
                         (lambda (p)
                           (let ((x (car p))
                                 (y (car (cdr p))))
                             (transform (list (- x) y))))
                         win color other-color))))))
  
  (set!
    overlay
    (lambda (image . images)
      (if (not (image? image))
          (error "overlay: input not an image" image)
          (let ((w (image-width image))
                (h (image-height image)))
            (for-each
              (lambda (i)
                (if (not (image? i))
                    (error "overlay: input not an image" i)
                    (if (not (and (= (image-width i) w)
                                  (= (image-height i) h)))
                        (error "Only images of equal size can be overlayed"
                               (cons image images)))))
              images)
            (make-image w h
                        (lambda (transform win color other-color)
                          (for-each
                            (lambda (image)
                              ((image-procedure image) transform win
                               color other-color))
                            (cons image images))))))))
  
  (set!
    resize-image
    (lambda (image . image-size)
      (if (not (image? image))
          (error "resize-image: input not an image" image)
          (let ((image-size (flesh-out-image-size image-size)))
            (make-image (car image-size) (cadr image-size)
                        (image-procedure image))))))
  
  (set!
    line
    (lambda (x0 y0 x1 y1 . image-size)
      (if (not (real? x0))
          (error "x0 argument to line not a real" x0))
      (if (not (real? x1))
          (error "x1 argument to line not a real" x1))
      (if (not (real? y0))
          (error "y0 argument to line not a real" y0))
      (if (not (real? y1))
          (error "y1 argument to line not a real" y1))
      (let ((image-size (flesh-out-image-size image-size)))
        (make-image (car image-size) (cadr image-size)
                    (lambda (transform win color other-color)
                      (let ((p1 (transform (list x0 y0)))
                            (p2 (transform (list x1 y1))))
                        (create <line>
                                win
                                (car p1) (cadr p1)
                                (car p2) (cadr p2)
                                with (fill-color: color))))))))
  
  (set!
    filled-triangle
    (lambda (x0 y0 x1 y1 x2 y2 . image-size)
      (if (not (real? x0))
          (error "x0 argument to filled-triangle not a real" x0))
      (if (not (<= -1 x0 1))
          (error "x0 argument to filled-triangle not in -1 to 1 range" x0))
      (if (not (real? x1))
          (error "x1 argument to filled-triangle not a real" x1))
      (if (not (<= -1 x1 1))
          (error "x1 argument to filled-triangle not in -1 to 1 range" x1))
      (if (not (real? x2))
          (error "x2 argument to filled-triangle not a real" x2))
      (if (not (<= -1 x2 1))
          (error "x2 argument to filled-triangle not in -1 to 1 range" x2))
      (if (not (real? y0))
          (error "y0 argument to filled-triangle not a real" y0))
      (if (not (<= -1 y0 1))
          (error "y0 argument to filled-triangle not in -1 to 1 range" y0))
      (if (not (real? y1))
          (error "y1 argument to filled-triangle not a real" y1))
      (if (not (<= -1 y1 1))
          (error "y1 argument to filled-triangle not in -1 to 1 range" y1))
      (if (not (real? y2))
          (error "y2 argument to filled-triangle not a real" y2))
      (if (not (<= -1 y2 1))
          (error "y2 argument to filled-triangle not in -1 to 1 range" y2))
      (let ((image-size (flesh-out-image-size image-size)))
        (make-image (car image-size) (cadr image-size)
                    (lambda (transform win color other-color)
                      (let ((p0 (transform (list x0 y0)))
                            (p1 (transform (list x1 y1)))
                            (p2 (transform (list x2 y2))))
                        (create <polygon>
                                win
                                (car p0) (cadr p0)
                                (car p1) (cadr p1)
                                (car p2) (cadr p2)
                                with (fill-color: color))))))))
  
  (waiter-write
   (lambda (obj)
     (if (image? obj)
         (begin
           (display (draw obj)) ; draw returns window title
           (newline))
         (normal-waiter-write obj)))))