;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CS101           Simple Graphics Package       Spring 2001
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;Load the DRSCHEME Graphics Library
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require-library "graphics.ss" "graphics")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; INITIALIZATION and FINALIZATION
;; Variables that define the size and shape of the graphics window.
;; Functions that set up and remove the graphics window and 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define *xstart* 300)
(define *ystart* 250)
(define *xend* 500)
(define *yend* 450)		
(define *height* (- *xend* *xstart*))
(define *width* (- *yend* *ystart*))
(define initialize-graphics 
  (lambda () (begin-graphics *xstart* *ystart* *xend* *yend*)))
(define finalize-graphics
  (lambda () (end-graphics)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; RECTANGLE data type.
;; A rectangle is a list with a type descriptor and four items, the 
;; X and Y coordinates of the lower left corner, the width and the height.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define make-rectangle 
  (lambda (left bottom width height)
    (list 'rectangle left bottom width height)))
(define rectangle-left (lambda (r) (cadr r)))
(define rectangle-bottom   (lambda (r) (caddr r)))
(define rectangle-width (lambda (r) (cadddr r)))
(define rectangle-height  (lambda (r) (car (cddddr r))))
(define rectangle-right  (lambda (r) (+ (rectangle-left r) (rectangle-width r))))
(define rectangle-top  (lambda (r) (+ (rectangle-bottom r) (rectangle-height r))))
(define rectangle? 
  (lambda (r) 
    (and (pair? r)
	 (equal? (car r) 'rectangle))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TRIANGLE data type.
;; A triangle is a list with a type descriptor and four items:	 
;; The X coordinate of the apex, the y coordinate of the bottom, the 
;; height and the width.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define make-triangle
  (lambda (apex bottom width height)
    (list 'triangle apex bottom width height)))
(define triangle-apex (lambda (t) (cadr t)))
(define triangle-bottom   (lambda (t) (caddr t)))
(define triangle-width (lambda (t) (cadddr t)))
(define triangle-height  (lambda (t) (car (cddddr t))))
(define triangle-left  (lambda (t) (- (triangle-apex t) 
                                                (/ (triangle-width t)2))))
(define triangle-right  (lambda (t) (+ (triangle-apex t) 
                                                 (/ (triangle-width t)2))))
(define triangle-top  (lambda (t) (+ (triangle-bottom t) 
                                               (triangle-height t))))
(define triangle? 
  (lambda (t) 
    (and (pair? t)
	 (equal? (car t) 'triangle))))


	
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HOUSE data type. (Version 1)
;; A house is a list with a type descriptor and two items: a rectangle 
;; (body) and a triangle (roof).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;(define build-house 
;;  (lambda (left bottom width height)
;;    (make-house (make-rectangle left bottom width height)
;;                (make-triangle (+ left (/ width 2))
;;                                         (+ bottom height)
;;                                         width
;;                                         height))))
;;(define make-house (lambda (body roof) (list 'house body roof)))
;;(define house-body (lambda (house) (cadr house)))
;;(define house-roof (lambda (house) (caddr house)))		
;;(define house-left (lambda (house) (rectangle-left (house-body house))))
;;(define house-bottom (lambda (house) (rectangle-bottom (house-body house))))
;;(define house-width (lambda (house) (rectangle-width (house-body house))))
;;(define house-height (lambda (house) (rectangle-height (house-body house))))
;;(define house? 
;;  (lambda (h) 
;;    (and (pair? h)
;;	 (equal? (car h) 'house))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HOUSE data type. (Version 2)
;; A house is a list with a type descriptor and four items: the X coordinate
;; of the left side of the body, the Y coordinate of the bottom of the body,
;; height of the body and the width of the body. 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define build-house 
  (lambda (left bottom width height)
    (make-house left bottom width height)))
(define make-house (lambda (left bottom width height) 
		     (list 'house left bottom width height))) 
(define house-body (lambda (house) 
		     (make-rectangle (house-left house)
				     (house-bottom house)
				     (house-width house)
				     (house-height house))))
(define house-roof (lambda (house) 
		     (make-triangle (+ (house-left house) (/ (house-width house) 2))
					      (+ (house-bottom house) (house-height house))
					      (house-width house)
					      (house-height house))))
(define house-left (lambda (house) (cadr house)))
(define house-bottom (lambda (house) (caddr house)))
(define house-width (lambda (house) (cadddr house)))
(define house-height (lambda (house) (car (cddddr house))))
(define house? 
  (lambda (h) 
    (and (pair? h)
	 (equal? (car h) 'house))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TOWER data type. 
;; A tower is a list with a type descriptor and two items: The first is 
;; a list of rectangles (base). The second is a triangle (roof).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define build-tower
  (lambda (n left bottom width height)
    (make-tower (build-tower-base n 
                                 left
                                 bottom
                                 width
                                 height)
                (make-triangle (+ left (/ width 2))
					 (+ bottom (* n height)) 
					 width 
					 height))))
(define build-tower-base 
  (lambda (n left bottom width height)
    (if (= n 0)
        '()
        (cons (make-rectangle left (+ bottom (* (- n 1) height))  width height)
              (build-tower-base (- n 1) left bottom width height)))))
(define make-tower (lambda (base roof) (list 'tower base roof)))
(define tower-base (lambda (tower) (cadr tower)))
(define tower-roof (lambda (tower) (caddr tower)))		
(define tower? 
  (lambda (t) 
    (and (pair? t)
	 (equal? (car t) 'tower))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ARCH data type. (Version 1)
;; An arch is a list with a type descriptor and three items: The first is 
;; a rectangle representing the left shpport. The second is a rectangle
;; representing the right support. The third is a rectangle representing
;; the top beam. (Only the constructors are given here. The access 
;; functions are omitted.)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define build-arch 
  (lambda (left bottom width height thickness)
    (make-arch (make-rectangle left bottom thickness height)
	       (make-rectangle (+ left (- width thickness))
			       bottom
			       thickness
			       height)
	       (make-rectangle left 
			       (+ bottom height)
			       width
			       thickness))))

(define make-arch 
  (lambda (left-support right-support top-beam)
    (list 'arch left-support right-support top-beam)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ARCH data type. (Version 2)
;; An arch is a list with a type descriptor and five numbers: The  
;; numbers represent the horizontal and vertical coordinates of the 
;; left and bottom sides of the arch; the height of the left and right 
;; supports; the width of the top beam; and the thickness of the 
;; supports and top beam. 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;(define build-arch
;;  (lambda (left bottom width height thickness)
;;    (make-arch left bottom width height thickness)))

;;(define make-arch 
;;  (lambda (left bottom width height thickness)
;;    (list 'arch left bottom width height thickness)))

	
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; STAIRCASE data type. 
;; A staircase is a list with a type descriptor and a list of rectangles.
;; Each rectangle on the list represents of the steps in the staircase.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define make-staircase (lambda (steps) (list 'staircase steps)))

(define build-staircase
  (lambda (n left bottom width height)
    (make-staircase (build-staircase-steps n left bottom width height))))
                     
(define build-staircase-steps 
  (lambda (n left bottom width height)
    (if (= n 0)
	'()
      (cons (make-rectangle left bottom (* n width) height)
	    (build-staircase-steps (- n 1) 
				   (+ left width)
				   (+ bottom height)
				   width 
				   height)))))

(define staircase-steps (lambda (staircase) (cadr staircase)))

(define staircase?
    (lambda (staircase) (and (pair? staircase)
			     (equal? (car staircase) 'staircase))))
	

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Drawing Routines: One routine for each type of object. 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define draw-rectangle 
  (lambda (r)
    (begin (goto (rectangle-left r) (rectangle-bottom r))
           (drawto (rectangle-left r) (rectangle-top r)) 	
           (drawto (rectangle-right r) (rectangle-top r)) 	
           (drawto (rectangle-right r) (rectangle-bottom r)) 	
           (drawto (rectangle-left r) (rectangle-bottom r))))) 	
(define draw-triangle
  (lambda (t)
    (begin (goto (triangle-left t) (triangle-bottom t))
           (drawto (triangle-apex t) (triangle-top t)) 	
           (drawto (triangle-right t) (triangle-bottom t)) 	
           (drawto (triangle-left t) (triangle-bottom t))))) 	
(define draw-house (lambda (house) 
                     (begin (draw-rectangle (house-body house))
                            (draw-triangle (house-roof house)))))
(define draw-tower (lambda (tower)
                     (begin (draw-triangle (tower-roof tower))
                            (draw-object-list (tower-base tower)))))
(define draw-staircase (lambda (staircase)
                         (draw-object-list (staircase-steps staircase))))
(define draw-arch (lambda (arch) 
                     (begin (draw-rectangle (arch-left-support arch))
			    (draw-rectangle (arch-right-support arch))
			    (draw-rectangle (arch-top-beam arch)))))
(define draw-pyramid (lambda (pyramid) 
		       (begin (draw-triangle (pyramid-roof pyramid))
			      (draw-object-list (pyramid-base pyramid)))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Generic Drawing Routines: Work with any typed object. 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define draw-object 
  (lambda (x)  
    (cond ((triangle? x) (draw-triangle x))
          ((rectangle? x) (draw-rectangle x))
          ((house? x) (draw-house x))
          ((tower? x) (draw-tower x))
          ((staircase? x) (draw-staircase x))
          ((arch? x) (draw-arch x))
          ((pyramid? x) (draw-pyramid x))
          (else #f))))

(define draw-object-list 
  (lambda (l)
    (if (null? l)
        #t
        (begin (draw-object (car l))
               (draw-object-list (cdr l))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;DEFAULT VERSIONS OF TYPE PREDICATES
;;These definitions are here to allow draw-object to work
;;before the arch and pyramid data types are implemented.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define arch? (lambda (x) #f))
(define pyramid? (lambda (x) #f))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ROUND: Must round all coordinates to integers before drawing.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define round (lambda (x) (floor (+ x 0.5))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DRAWING FUNCTION:  Change Scheme's coordinate system 
;; so that (0,0) is in the lower left corner, rather than 
;; the upper left corner. 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define goto (lambda (x y)
               (move-to (round x) (- *height* (round y)))))
(define drawto (lambda (x y)
                 (line-to (round x) (- *height* (round y)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;DRSCHEME Modifications 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(set! *height* 400)
(set! *width* 400)
(define initialize-graphics 
   (lambda ()
     (begin
      (open-graphics)
      (set! *viewport* (open-viewport "CS101-GRAPHICS" 400 400)))))
(define finalize-graphics 
   (lambda () (close-graphics)))  
(define *current* (make-posn 0 0))
(define *viewport* #f)
(define goto (lambda (x y) (set! *current* (make-posn (round x)
						      (round (- *height* y))))))
(define drawto 
   (lambda (x y) 
     (let* ((p1 *current*)
	    (p2 (make-posn (round x) (round (- *height* y)))))
      (set! *current* p2)
      ((draw-line *viewport*) p1 p2))))
						  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Expressions for initialization, finalization, building and drawing.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;(initialize-graphics)
;;(finalize-graphics)
(define *house* (build-house 10 10  100 100))
;;(draw-object *house*)
(define *tower* (build-tower 4 150 10 75 75))
;;(draw-object *tower*)
(define *staircase* (build-staircase 4 50 50 50 50))
;;(draw-object *staircase*)
;;(define *arch* (build-arch 10 10 50 50 10))
;;(draw-object *arch*)
;;(define *pyramid* (build-pyramid 3 10 10 50 50 10 10))
;;(draw-object *pyramid*)