;;; ;;; curve-ps3.ss ;;; UVA CS200 Spring 2003 ;;; 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)))