Spherical mirror demo

Get the Tcl plug-in around here (updated 6/01).

The lines reflect off the spherical mirror. You can drag the mirror around and adjust four other parameters. If you move the mouse on a line, the point of reflection will be labeled with the reflecting angle.

The point is that it is easy to see spherical abberation with this demo. The lines don't all intersect at the same point after reflecting in the spherical mirror.

I wrote this while taking Physics 7B at U.C. Berkeley, fall 1997.

reflect.tcl

#!/usr/bin/wish

canvas .c -bg white -width 630 -height 350 -closeenough 5 -bd 2 -relief sunken
pack .c -fill both -exp 1 -side top

proc control { text var from to } {
  global $var
  frame .f$var -bd 2 -relief raised
    label .f$var.l -width 20 -text $text
    scale .f$var.s -from $from -to $to -length 300 -orient horizontal -var $var
    pack .f$var.l -side left
    pack .f$var.s -side right -fill x -exp 1
  pack .f$var -side top
  bind .f$var.s <B1-Motion> {putlines}
}

control startlines startlines 0 700
control endlines endlines 0 700
control radius r 10 300
control spacing spacing 1 60

set startlines 32
set endlines 200
set spacing 12

set cx [expr (320+630)/2]
set cy [expr (24+334)/2]
set r 155

proc putlines { } {
 global cx cy r startlines endlines spacing
 .c delete rays
 .c delete circle
  .c create arc [expr $cx-$r] [expr $cy-$r] [expr $cx+$r] \
  [expr $cy+$r] -tags circle -width 2 -outline #004000 \
  -start -90 -extent 180 -style arc

for { set y $startlines } { $y < $endlines } { set y [expr $y+$spacing] } {
  if [catch {\
  set hitx [expr $cx+sqrt($r*$r-($y-$cy)*($y-$cy))]}] {
   .c create line 0 $y 1000 $y -tags rays -fill gray
   continue;
  }
  set angle [expr 3.1415/2.0*($y-$cy)/$r]
  set bx [expr $hitx-500*cos($angle)]
  set by [expr $y-500*sin($angle)]
 # .c create text [expr $hitx+15] $y -anc w -text $angle -tags rays
  set id [.c create line 0 $y $hitx $y $bx $by -arrow last -tags rays]
  .c bind $id <Enter> ".c itemconf $id -width 3 -fill red; \
     .c create text [expr $hitx+15] $y -anc w -text [expr int(abs($angle*180/6.28))] -tags txt"
  .c bind $id <Leave> ".c itemconf $id -wid 1 -fill black; .c delete txt"
}
}
putlines
set c .c
bind $c <1> "itemStartDrag $c %x %y"
bind $c <B1-Motion> "itemDrag $c %x %y"

proc itemStartDrag {c x y} {
    global lastX lastY
    set lastX [$c canvasx $x]
    set lastY [$c canvasy $y]
}

proc itemDrag {c x y} {
    global lastX lastY cx cy
    set x [$c canvasx $x]
    set y [$c canvasy $y]
    $c move circle [expr $x-$lastX] [expr $y-$lastY]
    set cx [expr $cx+($x-$lastX)]
    set cy [expr $cy+($y-$lastY)]
    putlines
    set lastX $x
    set lastY $y
}