#lang frtime (require frtime/animation frtime/gui) ;; Written by Evan Perillo ;; never run two display-envs at the same time or the images will overlap and not look nice ;; any relevant values can be set using the gui ;; 4 types of optical-devices can be used, concave-mirror, convex-mirror, concave-lens, and convex-lens ;; An example is already written at the bottom, just click run. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;TOP LEVEL FUNCTIONS;;;;;;;; ;creates and displays an environment with an optical device ;display-env : slider-input -> animation (define (display-env) (fresh-anim) (fresh-anim 599 599) (display-shapes (set-env (make-choice "Type of device" (list "Concave Mirror" "Convex Lens" "Convex Mirror" "Concave Lens")) (make-slider "Device Position" 1 599 399) mouse-pos (make-slider "Height" 1 100 50) (make-slider "Focal Length" 1 110 60) "blue"))) (define (concave-mirror x-val) ;; makes a concave mirror at x, y value determined by Base-Line (make-object "Concave Mirror" ;; gives a name to the optical device x-val ;; sets it at x value indicated 599 ;; determines if it converges or diverges (lambda (h ref-h) (make-posn (posn-x mouse-pos) ref-h)) ;; stores information regarding how the light reflects off of this object in a lambda function (lambda (f d-h) (make-posn f Base-Line)) -1 ;; determines whether this is a mirror or a Lens, ie. whether focus is negative or positive x value )) (define (convex-lens x-val) (make-object "Convex Lens" x-val 599 (lambda (h ref-h) (make-posn (posn-x mouse-pos) h)) (lambda (f d-h) (make-posn f Base-Line)) 1)) (define (convex-mirror x-val) (make-object "Convex Mirror" x-val 0 (lambda (h ref-h) (make-posn (posn-x mouse-pos) ref-h)) (lambda (f d-h) (make-posn f d-h)) -1)) (define (concave-lens x-val) (make-object "Concave Lens" x-val 0 (lambda (h ref-h) (make-posn (posn-x mouse-pos) h)) (lambda (f d-h) (make-posn f d-h)) 1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;MID LEVEL FUNCTIONS;;;;;;;; ;set-env: number(Op-d type) number(Op-D x value) mouse-input number(object height) number(focal-length) string -> void (animation) (define (set-env num x obj-pos obj-height f-length object-color) (let* ([obj (get-object num x)] [x-pos (posn-x obj-pos)] [x-val (object-x-val obj)] [y-val (object-y-val obj)] [Focal-Length f-length] [F (+ x-val (* (object-focus obj) Focal-Length))] [2F (- F (- x-val F))] [Fl (- x-val Focal-Length)] [2Fl (- Fl Focal-Length)] [Object-Height obj-height] [Height (- Base-Line Object-Height)] [Reflected-Height (+ Base-Line Object-Height)] [Double-Height (- Base-Line (* 2 Object-Height))] [Object-Distance (- x-val x-pos)] [Ray1-Posn ((object-ray1 obj) Height Reflected-Height)] [Ray2-Posn ((object-ray2 obj) F Double-Height)]) (define (in-bounds proc result) (if (< x-pos x-val) proc result)) (define (create-line proc) (in-bounds proc empty)) (define (return-string proc) (in-bounds proc "None")) (define (show-info proc) (if (>= x-pos x-val) proc "")) (define (get-image-type) (cond [(string=? (object-type obj) "Convex Mirror") (return-string "Virtual Erect Smaller")] [(string=? (object-type obj) "Concave Lens") (return-string "Virtual Erect Smaller")] [(string=? (object-type obj) "Concave Mirror") (get-image-type-converging 2F F)] [(string=? (object-type obj) "Convex Lens") (get-image-type-converging 2Fl Fl)])) (define (get-image-type-converging a b) (return-string (cond [(< (posn-x mouse-pos) a) "Real Inverted Smaller"] [(= (posn-x mouse-pos) a) "Real Inverted Equal"] [(and (> (posn-x mouse-pos) a) (< (posn-x mouse-pos) b)) "Real Inverted Larger"] [(= (posn-x mouse-pos) b) "None"] [(and (> (posn-x mouse-pos) b)) "Virtual Erect Larger"]))) ;;;;;;;;list of shapes to be drawn; (append (list (make-line (make-posn x-val 175) (make-posn x-val 375) "black") ;optical device (create-line (make-line (make-posn x-pos Base-Line) ;object (make-posn x-pos Height) object-color)) ;object (create-line (make-line (make-posn x-pos Height) ;incident ray 1 (make-posn x-val Base-Line) "green")) ;incident ray 1 (if (= x-pos x-val) null ;reflected ray 1 (create-line (make-line (make-posn x-val Base-Line) ;reflected ray 1 (get-end-posn Ray1-Posn (make-posn x-val Base-Line) 599) "green"))) ;reflected ray 1 (create-line (make-line (make-posn x-pos Height) ;incident ray 2 (make-posn x-val Height) "red")) ;incident ray 2 (create-line (make-line (make-posn x-val Height) ;reflected ray 2 (get-end-posn Ray2-Posn (make-posn x-val Height) y-val) "red")) ;reflected ray 2 (make-circle (make-posn F Base-Line) 2 "black") ; (make-circle (make-posn 2F Base-Line) 2 "black") ; Focal Points (make-circle (make-posn Fl Base-Line) 2 "black") ; (make-circle (make-posn 2Fl Base-Line) 2 "black") ; (make-graph-string (make-posn 20 20) (format "Type of Image Created: ~a" (get-image-type)) "black") (make-graph-string (make-posn 20 40) (format "ho: ~a do: ~a" (return-string Object-Height) (return-string Object-Distance)) object-color) (make-graph-string (make-posn 20 60) (format "~a ~a" (show-info "hi: None") (show-info "di: None")) "black") (make-graph-string (make-posn 20 80) (format "~a" (show-info "Magnification: None")) "red") (make-graph-string (make-posn 450 20) (object-type obj) "black") (make-graph-string (make-posn 450 40) "By: Evan Perillo" "black")) ;;;;;;Reflected Object;;;;;;;;;; (if (>= x-pos x-val) (list null) (let ((intersect (intersection Ray2-Posn (make-posn x-val Height) Ray1-Posn (make-posn x-val Base-Line)))) (if (string? intersect) (create-line (list null)) (create-line (list (make-line intersect (make-posn (posn-x intersect) Base-Line) "black") (make-graph-string (make-posn 20 60) (format "hi: ~a di: ~a" (exact->inexact (- Base-Line (posn-y intersect))) (exact->inexact (- x-val (posn-x intersect)))) "black") (make-graph-string (make-posn 20 80) (format "Magnification: ~a" (/ (- Base-Line (posn-y intersect)) Object-Height)) "red")))))) ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; BOTTOM LEVEL FUNCTIONS ;;; (define Base-Line 275) (define-struct object (type x-val y-val ray1 ray2 focus)) (define (get-object num x) (cond [(= 0 num) (concave-mirror x)] [(= 1 num) (convex-lens x)] [(= 2 num) (convex-mirror x)] [(= 3 num) (concave-lens x)])) (define (solve-x m1 m2 b1 b2) (if (= m1 m2) "DNE" (/ (- b2 b1) (- m1 m2)))) (define (solve-eq x m b) (if (string? x) "DNE" (+ (* m x) b))) (define (get-b y x m) (- y (* x m))) (define (get-x y m b) (/ (- y b) m)) (define (get-slope a b) (/ (- (posn-y b) (posn-y a)) (- (posn-x b) (posn-x a)))) (define (get-end-posn posn-a posn-b y-val) (define (get-end-x posn-a posn-b) (let ((slope (get-slope posn-a posn-b))) (get-x y-val slope (get-b (posn-y posn-a) (posn-x posn-a) slope)))) (make-posn (get-end-x posn-a posn-b) y-val)) ;intersection : posn posn posn posn -> posn or "DNE" (define (intersection line1a line1b line2a line2b) (let* ((m1 (get-slope line1a line1b)) (m2 (get-slope line2a line2b)) (b1 (get-b (posn-y line1a) (posn-x line1a) m1)) (b2 (get-b (posn-y line2a) (posn-x line2a) m2)) (x (solve-x m1 m2 b1 b2)) (y (solve-eq x m1 b1))) (if (string? x) "DNE" (make-posn x y)))) ;;;;;;;;;;;;;;;;Examples;;;;;;;;;;;;;; (display-env) ;creates and displays an optical device environment