;;;; DATA DIRECTED VERSION
(load "ch2support.scm")

(define pi (* 4 (atan 1)))

;;;MODIFIED FROM SECTION 2.4.2

(define (attach-tag type-tag contents)
  (cons type-tag contents))

(define (type-tag datum)
  (cond ((pair? datum)(car datum))
	((number? datum)'number) ;; now it accepts scheme numbers
	(else (error "Bad tagged datum -- TYPE-TAG" datum))))

(define (contents datum)
  (cond ((pair? datum)(cdr datum))
	((number? datum)datum)
	(else (error "Bad tagged datum -- CONTENTS" datum))))

;;;; UNMODIFIED FROM SECTION 2.4.2
(define (apply-generic op . args)
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (error
            "No method for these types -- APPLY-GENERIC"
            (list op type-tags))))))


;;; generic operations

(define (print x) (apply-generic 'print x))
(define (perimeter x) (apply-generic 'perimeter x))
(define (translate x delta-x delta-y) (apply-generic 'translate x delta-x delta-y))
(define (rotate x angle) (apply-generic 'rotate x angle))
(define (scale x factor) (apply-generic 'scale x factor))
(define (distance x y) (apply-generic 'distance x y))
;;; specific types

(define (install-point-package)
  ;;; internal procedures
  (define (get-x p)
    (car p))
  (define (get-y p)
    (cadr p))
  (define (make-point x y)
    (list x y))
  (define (distance p1 p2)
    (sqrt (+ (square (- (get-x p1) (get-x p2))) (square (- (get-y p1) (get-y p2))))))
  (define (print p)
    (display "(")(display (get-x p))(display ",")(display (get-y p))(display ")")(newline) #t)
  (define (perimeter p) 0)
  (define (translate p delta-x delta-y)
    (let ((x (get-x p))
	  (y (get-y p)))
    (make-point (+ x delta-x)
		(+ y delta-y))))
  (define (rotate p angle) ;; rotation around (0,0) through a counterclockwise angle in radians
    (let ((s (sin angle))
	  (c (cos angle))
	  (x (get-x p))
	  (y (get-y p)))
      (make-point (- (* c x)(* s y))
		  (+ (* s x)(* c y)))))
  (define (scale p factor)
    (let ((x (get-x p))
	  (y (get-y p)))
      (make-point (* x factor)
		  (* y factor))))
  ;;; interface
  (define (tag x) (attach-tag 'point x))
  (put 'get-x '(point)
       (lambda (point) (get-x point)))
  ;; non generic functions
  (put 'get-y '(point)
       (lambda (point) (get-y point)))
  (put 'make 'point
       (lambda (x y) (tag (make-point x y))))
  ;; GENERIC function implementation
  ;; 'number functions 
  (put 'distance '(point point)
       (lambda (p1 p2) (distance p1 p2)))
  (put 'perimeter '(point)
       (lambda (p) (perimeter p)))
  ;; boolean/void functions
  (put 'print '(point)
       (lambda (point) (print point)))
  ;; 'point functions
  (put 'translate '(point number number)
       (lambda (p dx dy) (tag (translate p dx dy))))
  (put 'rotate '(point number)
       (lambda (p angle) (tag (rotate p angle))))
  (put 'scale '(point number)
       (lambda (p factor) (tag (scale p factor))))
  'done)

(define (make-point2 x y)
  ((get 'make 'point) x y))

(install-point-package)

(define p4 (make-point2 1 2))
(define p5 (make-point2 2 3))

(distance p4 p5)

(translate p4 1 1)

(define p6 (rotate (make-point2 1 1) (/ pi 4)))

(scale p6 (sqrt 0.5))

(print p6)

;;; POLYGON PACKAGE

(define (install-polygon-package)
  ;;; internal procedures
  (define (make-polygon number-vert list-vert)
    (append (list number-vert) list-vert))
  (define (number-vert p) (car p))
  (define (list-vert p) (cdr p))
  (define (first-vert p) (cadr p))
  (define (next-vert l) (car l))
  (define (next-2-vert l) (cadr l))
  (define (perimeter-polygon p)
    (define (add result rest-vertices counter)
      (if (= counter (number-vert p))
	  (+ result (distance (first-vert p)(next-vert rest-vertices)))
	  (add (+ result (distance (next-vert rest-vertices) (next-2-vert rest-vertices)))
			 (cdr rest-vertices)
			 (1+ counter))))
    (add 0 (list-vert p) 1))
  (define (print-polygon pol)
    (begin
      (newline)
      (for-each (lambda (x) (print x)) (list-vert pol))
      #t))
  (define (translate-polygon pol delta-x delta-y)
    (make-polygon (number-vert pol)
      (map (lambda (x) (translate x delta-x delta-y))(list-vert pol))))
  (define (rotate-polygon pol angle) ;; rotation around (0,0) through a counterclockwise angle in radians
    (make-polygon (number-vert pol)
      (map (lambda (x) (rotate x angle))(list-vert pol))))
  (define (scale-polygon pol factor)
    (make-polygon (number-vert pol)
      (map (lambda (x) (scale x factor))(list-vert pol))))
  ;;; interface
  (define (tag x) (attach-tag 'polygon x))
  ;; non generic functions
  (put 'make 'polygon
       (lambda (number-vert list-vert) (tag (make-polygon number-vert list-vert))))
  ;; GENERIC function implementation
  ;; 'number functions 
  (put 'perimeter '(polygon)
       (lambda (pol) (perimeter-polygon pol)))
  ;; boolean/void functions
  (put 'print '(polygon)
       (lambda (pol) (print-polygon pol)))
  ;; 'polygon functions
  (put 'translate '(polygon number number)
       (lambda (pol dx dy) (tag (translate-polygon pol dx dy))))
  (put 'rotate '(polygon number)
       (lambda (pol angle) (tag (rotate-polygon pol angle))))
  (put 'scale '(polygon number)
       (lambda (pol factor) (tag (scale-polygon pol factor))))
  'done)

(define (make-polygon2 number-vert list-vert)
  ((get 'make 'polygon) number-vert list-vert))

(install-polygon-package)

(define pol4 (make-polygon2 3 (list p4 p5 p6)))
(print pol4)
(scale pol4 0.5)
(rotate pol4 (/ pi 4))
(translate pol4 1 1)
(perimeter pol4)