243 lines
9.5 KiB
Racket
243 lines
9.5 KiB
Racket
#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
|