;;;
;;; graphics.ss
;;; UVA CS200 Spring 2004
;;; Problem Set 3
;;;
;;; Version 1.0.1 - original version for PS2
;;; Version 1.0.2 - modified for PS3:
;;; - changed points to be lists instead of procedures
;;; - added color
;;; - improved efficiency using let (as in PS2 Question 6)
;;; - removed window opening (now in lsystem.ss)
(require (lib "graphics.ss" "graphics")) ;;; Load the graphics library
(require (lib "trace.ss"))
;;;
;;; Constants
;;;
(define window-width 600) ;;; Display window width
(define window-height 600) ;;; Display window height
;;; Angles
(define pi/4 (atan 1 1))
(define pi (* 4 pi/4))
(define -pi (- pi))
(define 2pi (* 2 pi))
;;;
;;; Points
;;;
(define (make-point x y) (list x y))
(define (make-color r g b)
(make-rgb (exact->inexact (/ r 256))
(exact->inexact (/ g 256))
(exact->inexact (/ b 256))))
(define (make-colored-point x y c) (list x y c))
(define (x-of-point point) (car point))
(define (y-of-point point) (cadr point))
(define (is-colored-point? point) (= (length point) 3))
;;; Regular points are black. Colored points have a color.
(define (color-of-point point)
(if (is-colored-point? point)
(caddr point)
(make-color 0 0 0)))
(define (show-point point)
(if (is-colored-point? point)
(list (x-of-point point) (y-of-point point) (color-of-point point))
(list (x-of-point point) (y-of-point point))))
;;;
;;; Drawing a curve
;;;
(define (draw-curve-points curve n)
(define (worker t step)
(if (<= t 1.0)
(begin (window-draw-point (curve t))
(worker (+ t step) step))))
(worker 0.0 (/ 1 n)))
(define (draw-curve-connected curve n)
(define (worker t step)
(if (<= t 1.0)
(begin (window-draw-line (curve t) (curve (+ t step)))
(worker (+ t step) step))))
(worker 0.0 (/ 1 n)))
;;;
;;; Some simple curves
;;;;
(define (mid-line t) (make-point t 0.5))
(define (unit-circle t) (make-point (sin (* 2pi t)) (cos (* 2pi t))))
(define (unit-line t) (make-point t 0.0))
(define (vertical-line t) (make-point 0.0 t))
;;;
;;; Functions for transforming curves into new curves.
;;;
(define (translate curve x y)
(lambda (t)
(let ((ct (curve t)))
(make-colored-point
(+ x (x-of-point ct))
(+ y (y-of-point ct))
(color-of-point ct)))))
(define (rotate-ccw curve)
(lambda (t)
(let ((ct (curve t)))
(make-colored-point
(- (y-of-point ct))
(x-of-point ct)
(color-of-point ct)))))
(define (flip-vertically curve)
(lambda (t)
(let ((ct (curve t)))
(make-colored-point
(* -1 (x-of-point ct))
(y-of-point ct)
(color-of-point ct)))))
(define (shrink curve scale)
(lambda (t)
(let ((ct (curve t)))
(make-colored-point
(* scale (x-of-point ct))
(* scale (y-of-point ct))
(color-of-point ct)))))
(define (first-half curve)
(lambda (t) (curve (/ t 2))))
(define (compose f g)
(lambda (x) (f (g x))))
(define rotate-cw (compose rotate-ccw flip-vertically))
(define (degrees-to-radians degrees)
(/ (* degrees pi) 180))
;;;
;;; rotate-around-origin counterclockwise by theta degrees
;;; (No need to worry about the geometry math for this.)
;;;
(define (rotate-around-origin curve theta)
(let ((cth (cos (degrees-to-radians theta)))
(sth (sin (degrees-to-radians theta))))
(lambda (t)
(let ((ct (curve t)))
(let ((x (x-of-point ct))
(y (y-of-point ct)))
(make-colored-point
(- (* cth x) (* sth y))
(+ (* sth x) (* cth y))
(color-of-point ct)))))))
;;;
;;; Scale a curve
;;;
(define (scale-x-y curve x-scale y-scale)
(lambda (t)
(let ((ct (curve t)))
(make-colored-point
(* x-scale (x-of-point ct))
(* y-scale (y-of-point ct))
(color-of-point ct)))))
(define (scale curve s) (scale-x-y curve s s))
;;; squeeze-rectangular-portion translates and scales a curve
;;; so the portion of the curve in the rectangle
;;; with corners xlo xhi ylo yhi will appear in a display window
;;; which has x, y coordinates from 0 to 1.
(define (squeeze-rectangular-portion curve xlo xhi ylo yhi)
(scale-x-y (translate curve (- xlo) (- ylo))
(/ 1 (- xhi xlo))
(/ 1 (- yhi ylo))))
;;;
;;; put-in-standard-position transforms a curve so that it starts at
;;; (0,0) ends at (1,0).
;;;
;;; A curve is put-in-standard-position by rigidly translating it so its
;;; start point is at the origin, then rotating it about the origin to put
;;; its endpoint on the x axis, then scaling it to put the endpoint at (1,0).
(define (put-in-standard-position curve)
(let* ((start-point (curve 0 (color-of-point curve)))
(curve-started-at-origin
(((translate (- (x-of-point start-point))
(- (y-of-point start-point)))
curve)))
(new-end-point (curve-started-at-origin 1))
(theta (atan (y-of-point new-end-point) (x-of-point new-end-point)))
(curve-ended-at-x-axis
((rotate-around-origin (- theta)) curve-started-at-origin))
(end-point-on-x-axis (x-of-point (curve-ended-at-x-axis 1))))
((scale (/ 1 end-point-on-x-axis)) curve-ended-at-x-axis)))
;;;
;;; connect-rigidly makes a curve consisting of curve1 followed by curve2.
;;;
(define (connect-rigidly curve1 curve2)
(lambda (t)
(if (< t (/ 1 2))
(curve1 (* 2 t))
(curve2 (- (* 2 t) 1)))))
;;;
;;; connect-ends
;;;
(define (connect-ends curve1 curve2)
(lambda (t)
(if (< t (/ 1 2))
(curve1 (* 2 t))
((translate curve2
(x-of-point (curve1 1)) (y-of-point (curve1 1))) (- (* 2 t) 1)))))
;;; (get-nth lst n) evaluates to the nth element in lst
(define (get-nth lst n)
(if (= n 0) (car lst) (get-nth (cdr lst) (- n 1))))
;;;
;;; (connect-curves-evenly curvelist)
;;; evaluates to a single curve made by connecting all the curves in curvelist
;;; in a way that will distribute all the t values evenly between all the curves.
;;;
(define (connect-curves-evenly curvelist)
(lambda (t)
(let ((which-curve
(if (>= t 1.0) (- (length curvelist) 1)
(inexact->exact (floor (* t (length curvelist)))))))
((get-nth curvelist which-curve)
(* (length curvelist)
(- t (* (/ 1 (length curvelist)) which-curve)))))))
;;;
;;; (cons-to-curvelist curve curvelist)
;;; evaluates to a list of curves that starts with curve and continues
;;; with the curves in curvelist, translated to begin where curve ends
;;;
(define (cons-to-curvelist curve curvelist)
(let ((endpoint (curve 1.0))) ;; The last point in curve
(cons curve
(map (lambda (thiscurve)
(translate thiscurve (x-of-point endpoint) (y-of-point endpoint)))
curvelist))))
;;;
;;; These procedures find the extents of a curve, so we can scale it to the window:
;;;
(define (find-extreme-point curve point-selector comparison n)
(define (worker t best-so-far step)
(if (> t 1.0)
;; check 1.0
(if (comparison (point-selector (curve 1.0)) best-so-far)
(point-selector (curve 1.0))
best-so-far)
(if (or (not best-so-far) (comparison (point-selector (curve t)) best-so-far))
(worker (+ t step) (point-selector (curve t)) step)
(worker (+ t step) best-so-far step))))
(worker 0.0 #f (/ 1 n)))
(define (find-leftmost-point curve n)
(find-extreme-point curve x-of-point < n))
(define (find-rightmost-point curve n)
(find-extreme-point curve x-of-point > n))
(define (find-lowest-point curve n)
(find-extreme-point curve y-of-point < n))
(define (find-highest-point curve n)
(find-extreme-point curve y-of-point > n))
;;; We add and subtract the .1's to make it not go quite to the edge of the window.
;;; (Perhaps these should scale instead...)
(define (position-curve curve startx starty)
(let ((tcurve (translate curve startx starty))
(num-points 1000)) ;;; How many points to evaluate
(let ((xlo (find-leftmost-point tcurve num-points))
(xhi (find-rightmost-point tcurve num-points))
(ylo (find-lowest-point tcurve num-points))
(yhi (find-highest-point tcurve num-points)))
(let ((xlowscale (if (< xlo 0.01)
(/ (- startx 0.01)
(- startx xlo))
1.0))
(xhighscale (if (> xhi 0.99)
(/ (- 0.99 startx)
(- xhi startx))
1.0))
(ylowscale (if (< ylo 0.01)
(/ (- starty 0.01)
(- ylo starty))
1.0))
(yhighscale (if (> yhi 0.99)
(/ (- 0.99 starty)
(- yhi starty))
1.0)))
(let
((minscale (min xlowscale xhighscale ylowscale yhighscale)))
(translate (scale-x-y curve minscale minscale) startx starty))))))
;;;
;;; Window procedures
;;;
(define (make-window width height name) (open-viewport name width height))
(define (close-window window) (close-viewport window))
(define (clear-window) ((clear-viewport window)))
;;;
;;; We need to convert a position in a (0.0, 0.0) - (1.0, 1.0) coordinate
;;; system to a position in a (0, window-height) - (window-width, 0) coordinate
;;; system. Note that the Viewport coordinates are upside down.
;;;
(define (convert-to-position point)
(check-valid-point point)
(make-posn (* (x-of-point point) window-width)
(- window-height (* window-height (y-of-point point)))))
;;; Passed values are in the unit (0.0, 0.0) - (1.0, 1.0) coordinate system.
;;; This procedure just prints a warning if a point is out of range
(define (check-valid-point point)
(let ((x (x-of-point point))
(y (y-of-point point)))
(if (or (< x 0.0) (> x 1.0))
(printf "Warning: point x coordinate is out of range (should be between 0.0 and 1.0): ~a~n" x))
(if (or (< y 0.0) (> y 1.0))
(printf "Warning: point y coordinate is out of range (should be between 0.0 and 1.0): ~a~n" y))))
(define (window-draw-point point)
((draw-pixel window) (convert-to-position point) (color-of-point point)))
;;; Draw a line on window from (x0, y0) to (x1, y1)
(define (window-draw-line point0 point1)
((draw-line window) ;;; evaluates to function for drawing on window
(convert-to-position point0)
(convert-to-position point1)))