;; This file contains definitions of quilt-cover "basic block" images for use
;; with Concrete Abstractions: An Introduction to Computer Science Using Scheme
;; by Max Hailperin, Barbara Kaiser, and Karl Knight.
;;
;; The images defined are:
;;  From chapter 1: rcross-bb, corner-bb, test-bb, and nova-bb
;;  From chapter 2: bitw-bb

;; 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 EdScheme version 5.0 for
;; Windows.  (Note that EdScheme for Macintosh uses a different version.)
;;
;; 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 "turtle step"
;;      defined by EdScheme.  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>.
;; Last revision May 17, 1998.

(define default-image-size 60)

(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 ((real-##write ##write))
  
  (define-structure image width height (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
    (let ((counter 0)
          (make-size-legal
            (lambda (size)
              (min 3000
                   (max 20
                        (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 (number->string counter)))
                (let ((win (make-graphics-window (list w h))))
                  (turtle-hide  win)
                  (window-set-title title win)
                  (clean win)
                  ((image-procedure image) (lambda (p)
                                             (list (* (car p) (/ w 2))
                                                   (* (cadr p) (/ h 2))))
                   win)
                  counter)))))))
  
  (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)
                        (polygon-paint (map transform
                                            '((-1 -1) (-1 1) (1 1) (1 -1)))
                                       win)
                        (let ((color (pen-color win))
                              (fg (fill-foreground-color win)))
                          (pen-set-color (map (lambda (x) (- 255 x)) color)
                                         win)
                          (fill-set-foreground-color (map (lambda (x) (- 255 x)) fg)
                                                     win)
                          ((image-procedure image) transform win)
                          (pen-set-color color win)
                          (fill-set-foreground-color fg win)))))))
  
  (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)
                                ((image-procedure top)
                                 (lambda (p)
                                   (let ((x (car p))
                                         (y (cadr p)))
                                     (transform (list x (+ (* top-scale y)
                                                           top-offset)))))
                                 win)
                                ((image-procedure bottom)
                                 (lambda (p)
                                   (let ((x (car p))
                                         (y (cadr p)))
                                     (transform (list x (+ (* bottom-scale y)
                                                           bottom-offset)))))
                                 win)))))))))
      (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)
                        ((image-procedure image)
                         (lambda (p)
                           (let ((x (first p))
                                 (y (first (rest p))))
                             (transform (list y (- x)))))
                         win))))))
  
  (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)
                        ((image-procedure image)
                         (lambda (p)
                           (let ((x (first p))
                                 (y (first (rest p))))
                             (transform (list (- x) y))))
                         win))))))
  
  (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)
                          (for-each
                            (lambda (image)
                              ((image-procedure image) transform win))
                            (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)
      (let ((image-size (flesh-out-image-size image-size)))
        (make-image (car image-size) (cadr image-size)
                    (lambda (transform win)
                      (polygon (map transform
                                    `((,x0 ,y0) (,x1 ,y1)))
                               win))))))
  
  (set!
    filled-triangle
    (lambda (x0 y0 x1 y1 x2 y2 . image-size)
      (let ((image-size (flesh-out-image-size image-size)))
        (make-image (car image-size) (cadr image-size)
                    (lambda (transform win)
                      (polygon-paint (map transform
                                          `((,x0 ,y0) (,x1 ,y1) (,x2 ,y2)))
                                     win))))))
  (set! ##write
        (lambda (obj port flag)
          (real-##write
            (if (image? obj)
                (draw obj)
                obj)
            port flag))))
;; A simple test image, to illustrate transformations.
(define test-bb
  (filled-triangle 0 1 0 -1 1 -1))

;; This one only has two triangles, but makes an interesting pinwheel.
(define nova-bb
  (overlay (filled-triangle 0 1 0 0 -1/2 0)
           (filled-triangle 0 0 0 1/2 1 0)))

;; Basic block for "Blowing in the Wind" quilting pattern from
;; "Quick-and-Easy Strip Quilting" by Helen Whitson Rose, Dover
;; Publications, New York, 1989, p. 59.
(define bitw-bb
  (overlay (overlay (filled-triangle -1 1 0 1 -1/2 1/2)
                    (filled-triangle -1 -1 0 -1 -1 0))
           (overlay (filled-triangle 1 1 1 0 0 0)
                    (filled-triangle 0 0 1 0 1/2 -1/2))))

;; The final two basic blocks defined in this file, rcross-bb and corner-bb,
;; are defined in a way intended to be unreasonably hard to understand, because
;; defining them is one of the exercises in the text.  It would be easier
;; for you to come up with your own definitions from scratch than by puzzling
;; these definitons out.  The only point of having them is to let you use the
;; blocks without first doing the definitions.  You might as well stop reading
;; here, the below is not meant to be readable.

;; Basic block for "Repeating Crosses" quilting pattern from
;; "Quick-and-Easy Strip Quilting" by Helen Whitson Rose, Dover
;; Publications, New York, 1989, p. 60.
(define rcross-bb #f)

;; A much simpler basic block, with one corner black.
(define corner-bb #f)

(let ((omb
        (lambda x
          (let l
            ((x (cdr x))
             (y (list-tail (cdr x) (quotient (length x) 2)))
             (z #f)
             (w (car x)))
            (if (null? y)
                z
                (l (cddddr x) (cddddr y)
                   (let* ((v (lambda (v) (/ v w)))
                          (v (filled-triangle (v (car y)) (v (car x))
                                              (v (cadr y)) (v (cadr x))
                                              (v (caddr y)) (v (caddr x)))))
                     (if z (overlay z v) v)) w))))))
  (set! rcross-bb (omb 2 2 2 1 1 1 2 1 2 1 1 -1 2 -1 -2 1
                       2 1 -1 -1 2 -2 2
                       -1 1 -1 2 2 1 2 1 1 -1 1 2 2 1 -1 -1 1 1))
  (set! corner-bb (omb -1 -1 -1 0 0 0 -1 -1 -1))
  )