Shared Graphics Tools for Physics Diagrams

Terry Honan

Blinn College - Bryan Campus

Abstract

Wolfram Language drawing tools for physics diagrams have been developed and will be shared. These have proven to be essential tools for creating interactive lecture notes for calculus-based physics at Blinn College, and should be of use to physicists and others. There are five packages: GraphicsTools, MechanicsTools, FieldLines, Circuit and GeometricOptics.  GraphicsTools and MechanicsTools include functions to draw labeled arrows, labeled double arrows, labeled angles, pulleys, springs and simple 2D cars and trucks. FieldLines traces the continuous field lines one expects in physics diagrams. Circuit is a versatile package for drawing circuit diagrams, both DC and AC. GeometricOptics draws optical components and traces rays. All tools are designed to work well inside Manipulate.

Overview

I am writing interactive lecture notes for calculus-based introductory physics. The ultimate goal of this is creating a full CDF-based interactive e-text. This project requires creating drawing tools, some are simple functions to save time on common task and others are more sophisticated programs.

The following packages will be shared.

GraphicsTools and MechanicsTools

Circuit

FieldPlot

GeometricOptics

The share location will be http://cit.blinn.edu/physics/Mathematica/index.html .

GraphicsTools and MechanicsTools Packages

<<GraphicsTools`
<<MechanicsTools`

Example - Pulley and LabeledArrow (with Code)

With[{a=2.0,b=3.,c=14,T=3,A=2.5},
GraphicsGrid[{{
Graphics[{
Line[{{-5,0},{-5,-16}}],
Line[{{5,0},{5,-12}}],
		Pulley[{0,0},{0,10},4.9,PulleyStyle->Spokes[]],
		{RGBColor[.4,.4,.6],
Rectangle[{-8,-22},{-2,-16}],
Rectangle[{2,-17},{8,-8}]},
RoundedBox[{-8,-22},{-2,-16},1.5],
RoundedBox[{2,-17},{8,-8},1.5],
{GrayLevel[1],Text["(Subscript[m, 1])",{-5,-19}],Text["(Subscript[m, 2])",{5,-12.5}]},
		{Thickness[.0125],ShadedLine[{{-c,10},{c,10}},1]}
},BaseStyle->{18,FontFamily->"Times"},ImageSize->300]
,
Graphics[{AbsoluteThickness[2.],Arrowheads[.125],
{{TColor,
LabeledArrow[{-a,0},{-a,T},"T",TextOffset->-.6]},{WColor,LabeledArrow[{-a,0},{-a,-2.5},"(Subscript[m, 1])g",TextOffset->1.2]},LabeledArrow[{-b,-A/2},{-b,A/2},"a",TextOffset->.8],
Text["(Subscript[m, 1])",{-a,3.5}],
{PointSize[.05],Point[{-a,0}]}},
{{TColor,LabeledArrow[{a,0},{a,T},"T",TextOffset->.6]},{WColor,LabeledArrow[{a,0},{a,-3.5},"(Subscript[m, 2])g",TextOffset->-1.2]},LabeledArrow[{b,A/2},{b,-A/2},"a",TextOffset->.8],Text["(Subscript[m, 2])",{a,3.5}],
{PointSize[.05],Point[{a,0}]}}
},BaseStyle->{18,FontFamily->"Times"},ImageSize->300]
}}]
]

?Pulley

Graphics[{Pulley[{0,0},{0,3},2,PulleyStyle->Spokes[]],Pulley[{6,0},{3,0},2]},ImageSize->300]

Example - SimpleTruck and AngleLabel (with Code)

With[{θ=35°,L=5,R=.5,a=6,b=8,
P0={0,0},
A={5,0},ACenter={0,1.5},T=7},
With[{P5=-Polar[5,90°-θ]},
Graphics[{{AbsoluteThickness[2.],Arrowheads[.06],LabeledArrow[ACenter-A/2,ACenter+A/2,"a",TextOffset->.75]},
{AbsoluteDashing[3],Line[{P0,{0,-3}}]},
Line[{P0,P5}],
AngleLabel[{-90°-θ,-90°},2,3,"θ"],
{RGBColor[.4,.4,.6],Disk[P5,R]},
{RoundedBox[P5,P5,1.2]},
SimpleTruck[{0,-0.8×2a},Scale->2a]},BaseStyle->{18,FontFamily->"Times"},ImageSize->500]]]

?AngleLabel

?SimpleTruck

With[{a=5},
Graphics[{
SimpleTruck[Scale->a],AbsolutePointSize[5],{Point[{0,.1 a}],Text[ "(0, 0.1 a)",{0,.1a}+{0,.075 a}]},{Point[#[[1]]],Text[#[[2]],#[[1]]+{0,-.075 a}]}&/@{{{0,0},"(0, 0)"},{{-.5 a,0},"(-0.5 a, 0)"},{{.5 a,0},"(0.5 a, 0)"},{{0,.8 a},"(0, 0.8 a)"},{{1.25  a,0},"(1.25 a, 0)"}},
Text["SimpleTruck[Scale->a]",{0,.45 a}]},BaseStyle->{18,FontFamily->"Times"},ImageSize->500]]

Example - SimpleCar, DoubleArrow and ShadedLine (with Code)

With[{r=x|->{x,-.01 (x^2)},xMax=50},
With[{R=50},
Graphics[{
{ShadedLine[Table[r[x],{x,-xMax,xMax,2 xMax/50}],-2,PolygonDirectives->{GrayLevel[.85]}]},
{AbsoluteDashing[2],AbsoluteThickness[.75],Circle[{0,-R},R,{0,π}]},
{Arrowheads[.03],DoubleArrow[{0,-R},{0,-R}+Polar[R,25°],Style["R",Italic,18],TextGap->.2]},
SimpleCar[Scale->10,CarColor->GrayLevel[0.6]],
With[{v=20,h=8},{LabeledArrow[{-v/2,h},{v/2,h},Style["(Subscript[v, max])=?",18],TextOffset->.7]}]
},BaseStyle->{18,FontFamily->"Times"},ImageSize->500]
]]

?SimpleCar

With[{dashedLines=a|->{AbsoluteDashing[2.5],Line[{{-a/2,1/6},{-a/2,-1/6}}],Line[{{a/2,1/6},{a/2,-1/6}}]},
txt=Style["a",18,Italic,FontFamily->"Times"],PR=PlotRange->{{-1.1,1.1},{-.2,.45}}},
GraphicsRow[{
With[{a=2},Graphics[{dashedLines[a],Arrowheads[.1],DoubleArrow[{-a/2,0},{a/2,0},txt,TextGap->.2]},ImageSize->150,PR]],
With[{a=.8},Graphics[{dashedLines[a],Arrowheads[.1],DoubleArrow[{-a/2,0},{a/2,0},txt,TextGap->0,TextOffset->.25]},ImageSize->150,PR]],
With[{a=.5},Graphics[{dashedLines[a],Arrowheads[.1],DoubleArrow[{-a/2,0},{a/2,0},txt,TextGap->3]},ImageSize->150,PR]],
With[{a=.15},Graphics[{dashedLines[a],Arrowheads[.1],DoubleArrow[{-a/2,0},{a/2,0},txt,TextGap->7.5,TextOffset->2.5]},ImageSize->150,PR]]
}]]

?DoubleArrow

Spring and ShadedLine Example (with Code)

With[{d0=7,R=.5,h=1.3},Manipulate[Graphics[{ShadedLine[{{12,-.65},{0,-.65},{0,R+.4}},.2],Spring[R,40,d0+x]},ImageSize->500],{{x,0,"x"},-4.5,4.5},SaveDefinitions->True]]

?Spring

?ShadedLine

Circuit Package

Simple Resistor Circuit (with Code)

<<Circuit`

?DrawCircuit

Graphics[
DrawCircuit[
{{-1,0},{1,0},{0,-1},{0,1},{-1,-1.5},{1,-1.5}},
{
{{1,3},{Resistor["(Subscript[R, 1])",TextOffset->-1]}},
{{3,2},{Resistor["(Subscript[R, 2])",TextOffset->-1]}},
{{1,4},{Resistor["(Subscript[R, 3])"]}},
{{4,2},{Resistor["(Subscript[R, 4])"]}},
{{3,4},{Resistor["(Subscript[R, 5])"]}},
{{1,5},{}},{{2,6},{}},
{{5,6},{DCVoltage["ℰ"]}}
},{{1,Node[Style["a",Italic],TextOffset->{-.6,0}]},{2,Node[Style["b",Italic],TextOffset->{.6,0}]}},TextOffsetScale->.75],BaseStyle->{18,FontFamily->"Times"}]

Circuit Elements (with Code)

Graphics[DrawCircuit[{{0,0},{1,0},{0,-.15},{1,-.15}},{{{1,2},{Resistor["R"],Capacitor["C"],Inductor["L"],DCVoltage["V"],ACVoltage["V"]}},
{{3,4},{CurrentArrow["I"],CurrentArrow["I",CurrentArrowType->"Offset Arrow",CurrentArrowDirectives->{Arrowheads[.03]}],InlineMeter["A"],Diode[]}}},TextOffsetScale->.75],BaseStyle->{18,Italic,FontFamily->"Times"},ImageSize->600]

More Options (with Code)

Graphics[DrawCircuit[
{{"a",{-3,0}},{"b",{-3,-3}},{"d",{0,0}},
{"e",{0,-3}},{"f",{3,0}},{"g",{3,-3}}},
{{{"b","d"},{Resistor["24 Ω",ResistorTurnNumber->20]}},
{{"b","e"},{Resistor["6 Ω",ResistorDirectives->{Darker[Red]}]}},
	{{"e","g"},{Resistor["6 Ω"]}},
{{"e","d"},{DCVoltage["4 V",DCVoltageGap->.075,DCVoltageShowPolarity->True,DCVoltageFlipped->True,DCVoltageNumberCells->5,DCVoltageDirectives->{AbsoluteThickness[1.5],Darker[Red]}],CurrentArrow["I",TextOffset->-.75,CurrentArrowType->"Offset Arrow",CurrentArrowFlipped->True,OffsetArrowOffset->-0.5`],Wire[.25]}},
	{{"d","g"},{Resistor["12 Ω",ResistorTurnNumber->20]}}},
TextOffsetScale->1.,ResistorDirectives->{Darker[Blue]}],BaseStyle->{18,FontFamily->"Times"},ImageSize->400]

Meters and Offsets - Full-wave Rectifier (with Code)

With[{R=.35,b=.5,c=.5,d=.75,e=.25,f=.1,g=.15,col1=Darker[Green],col2=Darker[Red,.2],col3=Darker[Blue,.3],col4=Darker[Orange,.3],xDiag=With[{x=.03,y=.02},{
AbsoluteThickness[2],Line[{#+{-x,-y},#+{x,y}}],Line[{#+{x,-y},#+{-x,y}}]}]&},
Graphics[{DrawCircuit[
{{1,{0,-1}},{2,{0,1}},{3,{-1,0}},{4,{1,0}},{7,{1+b,-1}},{8,{1+b,1}},{9,{c,0}},{10,{-c,0}},{11,{1+b,-d}},{12,{1+b,d}}},
{
{{12,11},{ACVoltage["(Subscript[V, rms])",ACVoltageRadius->R,TextOffset->-2.25]}},{{7,11},{}},{{12,8},{}},
{{7,1},{CurrentArrow["",CurrentArrowDirectives->col1],CurrentArrow["",CurrentArrowDirectives->col2,CurrentArrowFlipped->True]}},
{{2,8},{CurrentArrow["",CurrentArrowDirectives->col1],CurrentArrow["",CurrentArrowDirectives->col2,CurrentArrowFlipped->True]}},
{{1,4},{CurrentArrow["",CurrentArrowDirectives->col1],Wire[],Diode[],CurrentArrow["",CurrentArrowDirectives->col1],Wire[]}},
{{2,4},{Wire[],CurrentArrow["",CurrentArrowDirectives->col2],Diode[],Wire[],CurrentArrow["",CurrentArrowDirectives->col2]}},
{{3,2},{CurrentArrow["",CurrentArrowDirectives->col1],Wire[],Diode[],CurrentArrow["",CurrentArrowDirectives->col1],Wire[]}},
{{3,1},{CurrentArrow["",CurrentArrowDirectives->col2],Wire[],Diode[],CurrentArrow["",CurrentArrowDirectives->col2],Wire[]}},
{{4,9},{CurrentArrow["",CurrentArrowDirectives->col1],CurrentArrow["",CurrentArrowDirectives->col2]}},{{9,10},{Resistor["Load Resistance",ResistorTurnNumber->14,TextOffset->-1]}},{{10,3},{CurrentArrow["",CurrentArrowDirectives->col1],CurrentArrow["",CurrentArrowDirectives->col2]}},{OffsetPoints[{9,10},.15,.875,WireDirectives->col3],{InlineMeter[Style["(Subscript[V, L])",22,col3],InlineMeterRadius->R,InlineMeterDirectives->col3]}},{OffsetPoints[{11,12},.15,-1.25,WireDirectives->col4],{InlineMeter[Style["(Subscript[V, S])",22,col4],InlineMeterRadius->R,InlineMeterDirectives->col4]}}
},
BaseElementDirectives->AbsoluteThickness[2],CurrentArrowScale->1.5
],
{Style[{{col1,Text["+",{1+b+f,-e}],Text["-",{1+b+f,e}]},{col2,Text["-",{1+b-f,-e}],Text["+",{1+b-f,e}]}},14,Bold],{col1,Rotate[xDiag[{-g,-1+g}],π/4],Rotate[xDiag[{g,1-g}],π/4]},{col2,Rotate[xDiag[{1-g,-g}],-π/4],Rotate[xDiag[{-g,1-g}],-π/4]}}
},BaseStyle->{18,FontFamily->"Times"},ImageSize->500]]

Shading and Offsets - Full-wave Rectifier (with Code)

With[{col1=Darker[Green],col2=Darker[Red]},With[{a=.5,tOS=1.5,b=1.75,c=2.25,d=1.2,USW1=UnderShadeWrapper[{AbsoluteThickness[6],Opacity[.5],col1,CapForm["Butt"]}],USW2=UnderShadeWrapper[{AbsoluteThickness[6],Opacity[.5],col2,CapForm["Butt"]}]},
With[{
cir2=DrawCircuit[{{-d,0},{d,0}},
{{OffsetPoints[{1,2},.3,.875],{Resistor["(Subscript[R, 1])"]}},{{1,2},{Resistor["(Subscript[R, 2])"]}},{OffsetPoints[{1,2},.3,-.875],{Resistor["(Subscript[R, 3])"]}}},TextOffsetScale->tOS],
cir1=DrawCircuit[
{{1,{-b,0}},{2,{-1.5,0}},{3,{-.5,0}},{6,{b,0}},{5,{1.5,0}},{4,{.5,0}},{7,{-1.5,-a}},{8,{.5,-a}},{10,{1.5,a}},{9,{-.5,a}}},
{{{1,2},{Wire[0,WrapperFunction->USW1]}},
{{5,6},{Wire[0,WrapperFunction->USW2]}},
{{2,7},{Wire[0,WrapperFunction->USW1]}},
{{4,8},{Wire[0,WrapperFunction->USW1]}},
{{3,9},{Wire[0,WrapperFunction->USW2]}},
{{5,10},{Wire[0,WrapperFunction->USW2]}},
{{9,10},{Wire[0,WrapperFunction->USW2]}},
{{7,8},{Wire[0,WrapperFunction->USW1]}},
{{2,3},{Wire[0,WrapperFunction->USW1],Resistor["(Subscript[R, 1])",TextOffset->-tOS],Wire[0,WrapperFunction->USW2]}},
{{3,4},{Wire[0,WrapperFunction->USW2],Resistor["(Subscript[R, 2])",TextOffset->-tOS],Wire[0,WrapperFunction->USW1]}},{{4,5},{Wire[0,WrapperFunction->USW1],Resistor["(Subscript[R, 3])",TextOffset->-tOS],Wire[0,WrapperFunction->USW2]}}},TextOffsetScale->1.1]},
Graphics[{
{cir1,Style[{AbsolutePointSize[10],{col1,Point[{-b,0}],Text["1",{-b,-.33}]},{col2,Point[{b,0}],Text["2",{b,-.33}]}},18,Bold]},
Style[Text["⟹"],24]//Translate[#,{c,0}]&,
{Style[{AbsolutePointSize[12],{col1,Point[{-d,0}],Text["1",{-d,-.35}]},{col2,Point[{d,0}],Text["2",{d,-.35}]}},18,Bold],cir2}//Translate[#,{2c-.5,0}]&
},BaseStyle->{18,FontFamily->"Times"},ImageSize->500]
]]]

?UnderShadeWrapper

FieldLines Package

FieldLines is a package to draw the continuous field lines. In textbooks we draw field lines as continuous curves that can only begin at positive charges and end at negative charges.

To trace out a curve, we use NDSolve to integrate

((d(OverVector[r]))/(ds))=±(OverHat[E]),where(OverHat[E])=((OverVector[E])/(‖(OverVector[E])‖)),

where s becomes the arc length along the curve.

DrawFieldLines is the main function with the general syntax:

DrawFieldLines[starting positions, electric field, stopping conditions, options]

starting positions lists the starting point or points.

electric field is the electric field as a pure function of position.

stopping conditions are used to make the events that stop the NDSolve integration. These are Balls and Walls. Balls are either small balls around point charges or a large ball to enclose the whole graphic. Walls can set a rectangular region.

There are many options that can be added and there are options that can also be included in starting positions. as specific to a set of starting positions.

The option sMax gives the arc length for a curve. sMin sets the size of the small Balls.

The built-in function ContourPlot can create equipotentials and complements the field lines.

<<FieldLines`

With[{Q1=-18,x1=1.75,Q2=-14},
With[{eField=PointChargeField2D[{Q1,{x1,0}},{-Q1,{1/x1,0}},{Q2,{0,0}}],
V=PointChargePotential2D[{Q1,{x1,0}},{-Q1,{1/x1,0}},{Q2,{0,0}}]},
Show[{
With[{a=4,b=6},
ContourPlot[V[{x,y}],{x,-a,b},{y,-a,a},ContourShading->False,Contours->18,ContourStyle->Darker[Green,.6]]],
Graphics[{{RGBColor[0,0,.5],
DrawFieldLines[FromPointCharge[{x1,0},Abs[Q1]],eField,{Balls[3,{x1,0}],Balls[.05,{0,0},{1/x1,0}]},sMax->10,StepSize->0.02,ArrowheadScale->1],
DrawFieldLines[FromPointCharge[{0,0},Abs[Q2]],eField,{Balls[5,{x1,0}],Balls[.05,{3,0},{1/x1,0}]},sMax->10,StepSize->0.02,ArrowheadScale->1,sMin->.05]},
{GrayLevel[.8],Opacity[.6],Disk[]},
Text[Style["Conductor",16],{0,.15}],
Text[Style["Q",16,Italic],{0,-.15}],
{Darker[Green],Text[Style["q",16,Italic],{x1+.5,0}],
PointSize[.0385],Point[{x1,0}]}
}]},Frame->False,PlotRange->{{-2.25,3.5},2{-1,1}},AspectRatio->Automatic,BaseStyle->{12,FontFamily->"Times"}]]]

GeometricOptics Package

<<GeometricOptics`

Example - Image and Object for Thin Lens (with Code)

With[{p=20,h=20,f=30,AS=.05},With[{q=((((1/f)-(1/p)))^(-1)),hp=-h(1/p)((((1/f)-(1/p)))^(-1)),s={0,h},ital=Style[#,Italic]&},
Graphics[{Line[{{q-5,0},{f+10,0}}],
{RayColor,RayDashing,Line[{{-p,h},{q,hp}}],Line[{s,{q,hp}}]},
{RayColor,SegmentWithArrow[{-p,h},{0,0},{.5},ArrowSize->AS],
SegmentWithArrow[{0,0},1.3{p,-h},{1},ArrowSize->AS]},{RayColor,SegmentWithArrow[{-p,h},{0,h},{.5},ArrowSize->AS],
SegmentWithArrow[s,s+1.5({f,0}-s),{.3,1},ArrowSize->AS]},
{AbsoluteThickness[3],ConvergingLens[0,28],Text[Row[{"f"//ital," > 0"}],{0,32}],{ObjectColor,Object[-p,h,"object               ",TextOffset->0]},{ImageColor,VirtualDashing,Object[q,hp,"  image",TextOffset->6]}},
Text["f"//ital,{f,6}],
Text["f"//ital,{-f,-6}],
{ObjectColor,Text["h"//ital,{-p-6,h/2}],
Text["s",{-p,-6}]},
{ImageColor,Text[Row[{Superscript["h"//ital,′]}],{q+8,.5+hp/2}],
Text[Row[{Superscript["s"//ital,′]}],{q,-6}]},
{PointSize[.015],Point[{-f,0}],Point[{f,0}]}},BaseStyle->{18,FontFamily->"Times"},ImageSize->350,PlotRange->{{-75,45},{-35,75}}]]]

?SegmentWithArrow

?ConvergingLens

?Lens

?Object

Ray Tracing Example - Lensmaker Formula Derivation (with Code)

<<GraphicsTools`
<<GeometricOptics`

With[{x0=-80,h=.000001,R1=30,R2=60,H=25,n=3,T=15,ital=Style[#,Italic]&},
With[{w1=R1-(Sqrt[(R1^2)-(H^2)]),w2=R2-(Sqrt[(R2^2)-(H^2)]),sp1=n (((((n-1)/R1)+(1/x0)))^(-1))-1,s2=T-n (((((n-1)/R1)+(1/x0)))^(-1))},
With[{sp2= (((((1-n)/R2)-(n/s2)))^(-1)),xsp2=T+(((((1-n)/R2)-(n/s2)))^(-1))-2},
Graphics[{Lens[(T/2),H,R1,R2,MinimumConvergingThicknessFactor->(1/H) (T-w1+w2),ShowCentralLine->False],
{RayColor,TraceRay[SpreadDirections[{x0,h},{0,.4 H},5],CircularInterface[0,R1,1,n],CircularInterface[T,R2,n,1,TraceAhead->VerticalEquation[sp1]],60,ArrowSize->.0125,ArrowPositions->{.75,.6}]},
{Darker[Red],Thickness[.00075],Circle[{R1,0},R1,{95°,145°}],Circle[{R2+T,0},R2,{145°,165°}],Text[Row[{Subscript["R"//ital,"1"],"> 0"}],{12,25},{1,0}],Text[Row[{Subscript["R"//ital,"2"],"> 0"}],{23,25},{-1,0}]},
{Dashing[.005],
Line[{{x0,-2},{x0,-20}}],
Line[{{0,-2},{0,-40}}],
Line[{{T,-2},{T,-35}}],
Line[{{sp1,-2},{sp1,-40}}],
Line[{{xsp2,-2},{xsp2,-30}}]},
With[{yTxt=15},{Text["1",{T/2+4-12,yTxt}],Text["1",{T/2+4+12,yTxt}],Text[Style["n",Italic],{T/2+4,yTxt}]}],
{Arrowheads[.0125],DoubleArrow[{x0,-15},{0,-15},Row[{Subscript["s"//ital,"1"]}],TextGap->.075],
DoubleArrow[{0,-27.5},{T,-27.5},Style["t",Italic],TextGap->.25],
DoubleArrow[{T,-27.5},{xsp2,-27.5},Row[{Subsuperscript["s"//ital,"2","′"]}],TextGap->.325],
DoubleArrow[{T,-32.5},{sp1,-32.5},Row[{"-",Subscript["s"//ital,"2"]}],TextGap->.225],
DoubleArrow[{0,-37.5},{sp1,-37.5},Row[{Subsuperscript["s"//ital,"1","′"]}],TextGap->.125]},
{PointSize[.015],{ObjectColor,Point[{x0,0}]},{ImageColor,Point[{xsp2,0}]},Point[{sp1,0}]}
},BaseStyle->{16,FontFamily->"Times"},ImageSize->800]]]]

?TraceRay 
?SpreadDirections

Interactive Example - Ray Tracing (with Code)

With[{R=30,s0=42,TS=.5,h0=4,mirrorH=5,xRange={-20,50},ϵ=.01,txtObj="s",txtImg="s'"},
With[{f=(R/2),yMax=.85 mirrorH,overGraphics={CoordinateAxes[xRange,ArrowSize->1],
Text["f",{R/2,2.1}],Text["R",{R,-2}],Mirror[0,R,mirrorH]}},
Manipulate[
With[{s=With[{sMin=ϵ+R-√((R^2)-((pt[[2]])^2))},
Which[pt[[1]]<sMin,sMin,pt[[1]]>xRange[[2]]-ϵ,∞,True,pt[[1]]]],h=pt[[2]]},
With[{sp=If[s==f,∞,((((1/f)-(1/s)))^(-1))]},With[{hp=-h(sp/s)},
Graphics[{{RayColor,
TraceRay[
If[s==∞,
Table[{{xRange[[2]],y+h},-{xRange[[2]],h}+.0000000001},{y,-yMax,yMax,yMax/2}],
SpreadDirections[{s,h},{0,yMax},5]],
If[sp<0,CircularMirror[0,R,TraceBehind->VerticalEquation[sp]],CircularMirror[0,R]],Min[If[sp<0∨sp==∞,R,1.625 sp],45],ArrowPositions->{.6,.35},ArrowSize->.0125]},
overGraphics,
Switch[s,
∞,{AxesTicks[{f,R},TickSize->TS],PointSize[.010],{ImageColor,Point[{f,((-f)/(xRange[[2]]))h}]}},
f,{AxesTicks[{f,R},TickSize->TS],PointSize[.010],{ObjectColor,Point[{s,h}]}},
_,{PointSize[.010],AxesTicks[{f,R,s,sp},TickSize->TS],{ObjectColor,Point[{s,h}],Text[txtObj,{s,If[h>0,-1,+1]×2}]},{ImageColor,Point[{sp,hp}],Text[txtImg,{sp,If[hp>0,-1,+1]×1.3}]}}]
},BaseStyle->{16,Italic,FontFamily->"Times"},ImageSize->650,PlotRange->{xRange,{-7,7}}]]]],
{{pt,{s0,h0}},Locator,Appearance->None},AppearanceElements->{"ResetButton","HideControlsButton"},SaveDefinitions->True
]]]

Questions?