(*^ ::[paletteColors = 128; fontset = title, "New York", 24, L3, center, bold, nohscroll; fontset = subtitle, "New York", 18, L2, center, bold, nohscroll; fontset = subsubtitle, "New York", 14, L2, center, bold, nohscroll; fontset = section, "New York", 14, L2, bold, nohscroll, grayBox; fontset = subsection, "New York", 12, L2, bold, nohscroll, blackBox; fontset = subsubsection, "New York", 10, L2, bold, nohscroll, whiteBox; fontset = text, "New York", 12, L2, nohscroll; fontset = smalltext, "New York", 10, L2, nohscroll; fontset = input, "Courier", 12, L2, bold, nowordwrap; fontset = output, "Courier", 12, L2, nowordwrap; fontset = message, "Courier", 12, L2, R65535, nowordwrap; fontset = print, "Courier", 12, L2, nowordwrap; fontset = info, "Courier", 12, L2, nowordwrap; fontset = postscript, "Courier", 12, L2, nowordwrap; fontset = name, "Geneva", 10, L2, italic, B65535, nowordwrap, nohscroll; fontset = header, "Times", 10, L2; fontset = footer, "Times", 12, L2, center; fontset = help, "Geneva", 10, L2, nohscroll; fontset = clipboard, "New York", 12, L2; fontset = completions, "New York", 12, L2, nowordwrap; fontset = network, "Courier", 10, L2, nowordwrap; fontset = graphlabel, "Courier", 12, L2, nowordwrap; fontset = special1, "New York", 12, L2, nowordwrap; fontset = special2, "New York", 12, L2, center, nowordwrap; fontset = special3, "New York", 12, L2, right, nowordwrap; fontset = special4, "New York", 12, L2, nowordwrap; fontset = special5, "New York", 12, L2, nowordwrap;] :[font = input; initialization; ] *) BeginPackage["MONASSE`MathDraw`"] Null (* :[font = input; initialization; wordwrap; ] *) Point::usage= "Point[x,y] est le point de coordonnŽes (x,y). Point[u] retourne le point Point[u[1],u[2]]" RandomPoint::usage= " RandomPoint[...] retourne un point au hasard (voir les parametres habituels de Random)" PointQ::usage= "PointQ[M] teste si M est un point" StraightLine::usage= "StraightLine[u,v,w] est la droite d'Žquation ux+vy+w=0. StraightLine[Ox] et StraightLine[Oy] retournent les deux axes. StraightLine[u] retourne la droite StraightLine[u[1],u[2],u[3]]" RandomStraightLine::usage= " RandomStraightLine[...] retourne une droite au hasard (voir les parametres habituels de Random)" StraightLineQ::usage= "StraightLineQ[D] teste si D est une droite" CircleAlone::usage= "CircleAlone[x,y,r] est le cercle de centre (x,y) de rayon r" BarycentricCoordinates::usage= "BarycentricCoordinates[M,{A1,A2,A3}] retourne la liste des coordonnees barycentriques de M dans le repre affine (A1,A2,A3)" StraightLineByTwoPoints::usage= "StraightLineByTwoPoints[M1,M2] renvoie la droite passant par les points M1 et M2. Abreviation M1.M2" PointParameter::usage= "PointParameter[Objet,t] renvoie le point de parametre t de l'objet qui peut tre une droite ou un cercle" CircleCenter::usage="CircleCenter[C] renvoie le centre du cercle C" CircleByCenterAndPoint::usage= "CircleByCenterAndPoint[C,M] renvoie le cercle de centre C passant par M" Intersection::usage= "Intersection[Objet1,Objet2] renvoie le ou les points d'intersection des deux objets (droites ou cercles). AbrŽviation Objet1*Objet2." StraightLineParallel::usage="StraightLineParallel[D,M] renvoie la droite parallele ˆ D passant par M" StraightLinePerpendicular::usage= "StraightLinePerpendicular[D,M] renvoie la droite perpendiculaire ˆ D passant par M" Symmetric::usage= "Symmetric[Objet1,Objet2] renvoie le Symmetric de Objet1 (StraightLine, CircleAlone ou Point) par rapport ˆ Objet2 (StraightLine ou Point). AbrŽviation Objet1/Objet2" Middle::usage= "Middle[M1,M2] renvoie le Middle de M1 et M2" Mediatrix::usage="Mediatrix[M1,M2] renvoie la droite mŽdiatrice des deux points M1 et M2" Bisectors::usage= "Bisectors[D1,D2] renvoie les deux Bisectors des droites D1 et D2" Projection::usage= "Projection[M,Objet] renvoie le point projection de M sur Objet (StraightLine ou CircleAlone). AbrŽviation M>Objet" (* Quelques constructions supplŽmentaires *) CircleByDiameter::usage= "CircleByDiameter[A,B] retourne le cercle de diametre AB" CircleByThreePoints::usage= "CircleByThreePoints[A,B,C] retourne le cercle passant par les trois points A,B et C" CenterOfGravity::usage= "CenterOfGravity[A,B,C] retourne le centre de gravitŽ de A,B et C" Orthocenter::usage= "Orthocenter[A,B,C] retourne l'Orthocenter du triangle de sommets A,B et C" CenterOfCircumscribedCircle::usage= "CenterOfCircumscribedCircle[A,B,C] retourne le centre du cercle circonscrit au triangle de sommets A,B et C" CenterOfInscribedCircle::usage= "CenterOfInscribedCircle[A,B,C] retourne le centre du cercle inscrit dans le triangle de sommets A,B et C" StraightLineEuler::usage= "StraightLineEuler[A,B,C] retourne la droite d'Euler du triangle ABC" StraightLinesEnvelope::usage= "StraightLinesEnvelope[D,t] retourne l'enveloppe de la famille de droites D par rapport au paramtre t" Draw::usage= "Draw[{liste},{xMin,xMax},{yMin,yMax}] dessine, dans un rectangle dŽlimitŽ par xMin, xMax, yMin et yMax la figure formŽe par la liste d'objets. La liste d'objets peut tre constituŽe de points, de droites, de cercles, de points nommŽs (de la forme {Point[x,y],nom}, le nom du point sera portŽ ˆ cotŽ du point) et de tout objet graphique Mathematica habituel (y compris les changements de couleur)" (* Quelques tests utiles en gŽomŽtrie *) EqualQ::usage= "EqualQ[Objet1,Objet2] teste si les deux objets sont Žgaux. AbrŽviation Objet1==Objet2" ParallelQ::usage= "ParallelQ[D1,D2] teste si les deux droites sont paralleles" PerpendicularQ::usage= "PerpendicularQ[D1,D2] teste si les deux droites sont perpendiculaires" ConcentricQ::usage= "ConcentricQ[C1,C2] teste si les deux cercles sont concentriques" OfQ::usage= "OfQ[M,Objet] ou OfQ[Objet,M] teste si le point appartient ˆ Objet (CircleAlone ou StraightLine)" AlignedQ::usage= "AlignedQ[M1,M2,M3] teste si trois points sont alignŽs" ConcurrentQ::usage= "ConcurrentQ[D1,D2,D3] teste si trois droites sont concourantes ou parallŽles" TangentQ::usage="TangentQ[D,C] teste si la droite D est tangente au cercle C" Begin["`private`"] Null (* ;[s] 5:0,0;3605,1;3616,0;3670,2;3704,0;4468,-1; 3:3,14,10,Courier,1,12,0,0,0;1,14,10,Courier,3,12,0,0,0;1,14,10,Courier,0,12,0,0,0; :[font = input; initialization; startGroup; ] *) Unprotect[Point,Intersection] p0=Point[0,0] FauxPoint=Point[Indeterminate,Indeterminate] Point[u_]:=Point[u[1],u[2]]/;AtomQ[u] && !NumberQ[u] PointQ[M_]:=(Head[M]==Point) RandomPoint[u___]:=Point[Random[u],Random[u]] d0=StraightLine[0,0,0] StraightLine[Ox]=StraightLine[0,1,0] StraightLine[Oy]=StraightLine[1,0,0] StraightLine[u_]:=StraightLine[u[1],u[2],u[3]]/;AtomQ[u] && !NumberQ[u] RandomStraightLine[u___]:=StraightLine[Random[u],Random[u],Random[u]] StraightLineQ[D_]:=(Head[D]==StraightLine) normalise[StraightLine[u_,v_,w_]]:=Block[{norme=Sqrt[u^2+v^2]}, If[norme==0, d0, StraightLine[u/norme,v/norme,w/norme], StraightLine[u/norme,v/norme,w/norme] ] ] BarycentricCoordinates[M_,{A1_,A2_,A3_}]:=Block[{x,y,z}, Return[LinearSolve[ {{A1[[1]],A2[[1]],A3[[1]]}, {A1[[2]],A2[[2]],A3[[2]]}, {1,1,1}},{M[[1]],M[[2]],1}] ] ]/;PointQ[M] && PointQ[A1] && PointQ[A2] && PointQ[A3] CircleCenter[CircleAlone[x_,y_,r_]]:=Point[x,y] PointParameter[CircleAlone[a_,b_,r_],t_]:=Point[a+r*Cos[t],b+r*Sin[t]] PointParameter[D_,t_]:=Block[{d=normalise[D]}, Together/@Point[-d[[3]]*d[[1]]-t*d[[2]],-d[[3]]*d[[2]]+t*d[[1]]] ]/;StraightLineQ[D] StraightLineByTwoPoints[P_,Q_]:=Together/@StraightLine[P[[2]]-Q[[2]],Q[[1]]-P[[1]],P[[1]]*Q[[2]]-P[[2]]*Q[[1]]]/;PointQ[P] && PointQ[Q] CircleByCenterAndPoint[P_,Q_]:=CircleAlone[P[[1]],P[[2]],Sqrt[(Q[[1]]-P[[1]])^2+(Q[[2]]-P[[2]])^2]]/;PointQ[P] && PointQ[Q] StraightLine/: Intersection[StraightLine[u1_,v1_,w1_],StraightLine[u2_,v2_,w2_]]:=Block[{det=u1*v2-u2*v1}, If[det==0, FauxPoint, Together/@Point[(v1*w2-w1*v2)/det,(w1*u2-u1*w2)/det], Together/@Point[(v1*w2-w1*v2)/det,(w1*u2-u1*w2)/det] ] ] StraightLine/: Intersection[StraightLine[u_,v_,w_],CircleAlone[a_,b_,r_]]:=Block[{ delta=r^2*(u^2+v^2)-(u*a+v*b+w)^2, b1=-b*u*v+a*v^2-u*w, b2=-a*u*v+b*u^2-v*w, den=u^2+v^2}, If[delta<0, {FauxPoint,FauxPoint}, {Together/@Point[(b1+v*Sqrt[delta])/den,(b2-u*Sqrt[delta])/den],Together/@Point[(b1-v*Sqrt[delta])/den,(b2+u*Sqrt[delta])/den]}, {Together/@Point[(b1+v*Sqrt[delta])/den,(b2-u*Sqrt[delta])/den],Together/@Point[(b1-v*Sqrt[delta])/den,(b2+u*Sqrt[delta])/den]}] ] StraightLine/: Intersection[CircleAlone[a_,b_,r_],StraightLine[u_,v_,w_]]:=Intersection[StraightLine[u,v,w],CircleAlone[a,b,r]] CircleAlone/: Intersection[CircleAlone[a1_,b1_,r1_],CircleAlone[a2_,b2_,r2_]]:=Intersection[ StraightLine[2*(a2-a1),2*(b2-b1), a1^2-a2^2+b1^2-b2^2-r1^2+r2^2] ,CircleAlone[a2,b2,r2]] StraightLineParallel[StraightLine[u_,v_,w_],Point[a_,b_]]:=Together/@StraightLine[u,v,-u*a-v*b] StraightLineParallel[Point[a_,b_],StraightLine[u_,v_,w_]]:=Together/@StraightLine[u,v,-u*a-v*b] StraightLinePerpendicular[StraightLine[u_,v_,w_],Point[a_,b_]]:=Together/@StraightLine[-v,u,v*a-u*b] StraightLinePerpendicular[Point[a_,b_],StraightLine[u_,v_,w_]]:=Together/@StraightLine[-v,u,v*a-u*b] Symmetric[D1_,D2_]:=Block[{d1=normalise[D1],d2=normalise[D2],lambda}, lambda=-2*(d1[[1]]*d2[[1]]+d1[[2]]*d2[[2]]); Together/@StraightLine[d1[[1]]+lambda*d2[[1]],d1[[2]]+lambda*d2[[2]],d1[[3]]+lambda*d2[[3]]] ] /; StraightLineQ[D1] && StraightLineQ[D2] Symmetric[M_,D_]:=Block[{d=normalise[D],t}, t=M[[1]]*d[[1]]+M[[2]]*d[[2]]+d[[3]]; Together/@Point[M[[1]]-2*t*d[[1]],M[[2]]-2*t*d[[2]]] ]/;PointQ[M] && StraightLineQ[D] Symmetric[M_,S_]:=Together/@Point[2*S[[1]]-M[[1]],2*S[[2]]-M[[2]]]/;PointQ[M] && PointQ[S] Symmetric[D_,S_]:=Together/@StraightLine[D[[1]],D[[2]],-D[[3]]+2*D[[1]]*S[[1]]+2*D[[2]]*S[[2]]]/;PointQ[S] && StraightLineQ[D] Mediatrix[Point[a1_,b1_],Point[a2_,b2_]]:=Together/@StraightLinePerpendicular[StraightLineByTwoPoints[Point[a1,b1],Point[a2,b2]],Point[(a1+a2)/2,(b1+b2)/2]] Middle[Point[a1_,b1_],Point[a2_,b2_]]:=Together/@Point[(a1+a2)/2,(b1+b2)/2] Bisectors[D1_,D2_]:=Block[{d1=normalise[D1],d2=normalise[D2]}, {Together/@StraightLine[d1[[1]]+d2[[1]],d1[[2]]+d2[[2]],d1[[3]]+d2[[3]]], Together/@StraightLine[d1[[1]]-d2[[1]],d1[[2]]-d2[[2]],d1[[3]]-d2[[3]]]} ] /; StraightLineQ[D1] && StraightLineQ[D2] Projection[M_,D_]:=Block[{d=normalise[D],t}, t=M[[1]]*d[[1]]+M[[2]]*d[[2]]+d[[3]]; Together/@Point[M[[1]]-t*d[[1]],M[[2]]-t*d[[2]]] ]/;PointQ[M] && StraightLineQ[D] Projection[M_,C_]:=Block[{Norme=Sqrt[(M[[1]]-C[[1]])^2+(M[[2]]-C[[2]])^2],t}, If[Norme==0, FauxPoint, Together/@Point[C[[1]]+(M[[1]]-C[[1]])*C[[3]]/norme,C[[2]]+(M[[2]]-C[[2]])*C[[3]]/norme], Together/@Point[C[[1]]+(M[[1]]-C[[1]])*C[[3]]/norme,C[[2]]+(M[[2]]-C[[2]])*C[[3]]/norme] ] ]/;PointQ[M] && Head[C]==CircleAlone EqualQ[StraightLine[u1_,v1_,w1_],StraightLine[u2_,v2_,w2_]]:=(u1*v2-v1*u2==0 && v1*w2-w1*v2==0 && w1*u2-w2*u1==0) EqualQ[M1,M2]:=(M1==M2)/;PointQ[M1] && PointQ[M2] EqualQ[C1,C2]:=(C1==C2)/;Head[C1]==CircleAlone && Head[C2]==CircleAlone ParallelQ[StraightLine[u1_,v1_,w1_],StraightLine[u2_,v2_,w2_]]:=Block[{val=u1*v2-v1*u2}, If[NumberQ[val], Chop[val]==0, val==0] ] PerpendicularQ[StraightLine[u1_,v1_,w1_],StraightLine[u2_,v2_,w2_]]:=Block[{val=u1*u2+v1*v2}, If[NumberQ[val], Chop[val]==0, val==0] ] OfQ[Point[x_,y_],StraightLine[u_,v_,w_]]:=Block[{val=u*x+v*y+w}, If[NumberQ[val], Chop[val]==0, val==0] ] OfQ[Point[x_,y_],CircleAlone[a_,b_,r_]]:=Block[{val=(x-a)^2+(y-b)^2-r^2}, If[NumberQ[val], Chop[val]==0, val==0] ] AlignedQ[M1_,M2_,M3_]:=Block[{val=Det[{{M1[[1]],M1[[2]],1},{M2[[1]],M2[[2]],1}, {M3[[1]],M3[[2]],1}}]}, If[NumberQ[val], Chop[val]==0, val==0] ]/;PointQ[M1] && PointQ[M2] && PointQ[M3] ConcurrentQ[D1_,D2_,D3_]:=Block[{val=Det[{{D1[[1]],D1[[2]],D1[[3]]},{D2[[1]],D2[[2]],D2[[3]]}, {D3[[1]],D3[[2]],D3[[3]]}}]}, If[NumberQ[val], Return[Chop[val]==0], Return[val==0]] ]/;StraightLineQ[D1] && StraightLineQ[D2] && StraightLineQ[D3] TangentQ[StraightLine[u_,v_,w_],CircleAlone[a_,b_,r_]]:=r^2*(u^2+v^2)-(u*a+v*b+w)^2==0 Unprotect[Times,Greater,Divide,Dot] Point/: Dot[Point[x1_,y1_],Point[x2_,y2_]]:=StraightLineByTwoPoints[Point[x1,y1],Point[x2,y2]] StraightLine/: Times[StraightLine[u1_,v1_,w1_],StraightLine[u2_,v2_,w2_]]:=Intersection[StraightLine[u1,v1,w1],StraightLine[u2,v2,w2]] StraightLine/: Times[StraightLine[u_,v_,w_],CircleAlone[a_,b_,r_]]:=Intersection[StraightLine[u,v,w],CircleAlone[a,b,r]] StraightLine/: Times[CircleAlone[a_,b_,r_],StraightLine[u_,v_,w_]]:=Intersection[StraightLine[u,v,w],CircleAlone[a,b,r]] CircleAlone/: Times[CircleAlone[a1_,b1_,r1_],CircleAlone[a2_,b2_,r2_]]:=Intersection[CircleAlone[a1,b1,r1],CircleAlone[a2,b2,r2]] Point/: Greater[Point[x_,y_],StraightLine[u_,v_,w_]]:=Projection[Point[x,y],StraightLine[u,v,w]] Point/: Greater[Point[x_,y_],CircleAlone[a_,b_,r_]]:=Projection[Point[x,y],CircleAlone[a,b,r]] Point/: Divide[Point[x_,y_],StraightLine[u_,v_,w_]]:=Symetrie[Point[x,y],StraightLine[u,v,w]] Point/: Divide[StraightLine[u_,v_,w_],Point[x_,y_]]:=Symetrie[StraightLine[u,v,w],Point[x,y]] Point/: Divide[Point[x1_,y1_],Point[x2_,y2_]]:=Symetrie[Point[x1,y1],Point[x2,y2]] StraightLine/: Divide[StraightLine[u1_,v1_,w1_],StraightLine[u2_,v2_,w2_]]:=Symetrie[StraightLine[u1,v1,w1],StraightLine[u2,v2,w2]] Protect[Point,Intersection,Times,Greater,Divide,Dot] Clippe[StraightLine[u_,v_,w_],{x0_,x1_},{y0_,y1_}]:= If[Abs[v]>Abs[u], Return[Line[{{x0,-(u*x0+w)/v},{x1,-(u*x1+w)/v}}]], Return[Line[{{-(v*y0+w)/u,y0},{-(v*y1+w)/u,y1}}]] ] DrawRules[{xMin_,xMax_},{yMin_,yMax_}]= { {Point[a_,b_],nom_}:>Apply[Sequence,{Point[{a,b}],Text[nom,{a,b},{-1,-1}]}], Point[Indeterminate,Indeterminate]:>Point[{xMin-1,yMin-1}], Point[a_,b_]:>Point[{a,b}], CircleAlone[a_,b_,r_]:>Circle[{a,b},r], StraightLine[0,0,0]:>Point[{xMin-1,yMin-1}], StraightLine[u_,v_,w_]:>Clippe[StraightLine[u,v,w],{xMin,xMax},{yMin,yMax}] } Draw[laListe_,{xMin_,xMax_},{yMin_,yMax_}]:=Block[{l=laListe}, l=l/.DrawRules[{xMin,xMax},{yMin,yMax}]; PrependTo[l,PointSize[.02]]; Show[Graphics[l, {AspectRatio->Automatic, PlotRange->{{xMin,xMax},{yMin,yMax}}}]]] (* Constructions supplŽmentaires *) CircleByDiameter[A_,B_]:=CircleByCenterAndPoint[Middle[A,B],A]/;PointQ[A] && PointQ[B] CircleByThreePoints[A_,B_,C_]:=CircleByCenterAndPoint[CenterOfCircumscribedCircle[A,B,C],A]/;PointQ[A] && PointQ[B] && PointQ[C] CenterOfGravity[A_,B_,C_]:=Point[(A[[1]]+B[[1]]+C[[1]])/3,(A[[2]]+B[[2]]+C[[2]])/3]/;PointQ[A] && PointQ[B] && PointQ[C] Orthocenter[A_,B_,C_]:=Block[{BC=StraightLineByTwoPoints[B,C], AC=StraightLineByTwoPoints[A,C],AH,BH}, AH=StraightLinePerpendicular[BC,A]; BH=StraightLinePerpendicular[AC,B]; Intersection[AH,BH] ]/;PointQ[A] && PointQ[B] && PointQ[C] CenterOfCircumscribedCircle[A_,B_,C_]:=Intersection[Mediatrix[A,B],Mediatrix[A,C]]/;PointQ[A] && PointQ[B] && PointQ[C] distance[Point[a1_,b1_],Point[a2_,b2_]]:=Sqrt[(a1-a2)^2+(b1-b2)^2] CenterOfInscribedCircle[A_,B_,C_]:=Block[{a=distance[B,C], b=distance[C,A], c=distance[A,B]}, Point[(a*A[[1]]+b*B[[1]]+c*C[[1]])/(a+b+c), (a*A[[2]]+b*B[[2]]+c*C[[2]])/(a+b+c)] ]/;PointQ[A] && PointQ[B] && PointQ[C] StraightLineEuler[A_,B_,C_]:=StraightLineByTwoPoints[ CenterOfCircumscribedCircle[A,B,C], Orthocenter[A,B,C]]/;PointQ[A] && PointQ[B] && PointQ[C] StraightLinesEnvelope[StraightLine[u_,v_,w_],t_]:=Intersection[StraightLine[u,v,w], StraightLine[D[u,t],D[v,t],D[w,t]]] End[] Null (* :[font = message; inactive; endGroup; ] End::top: No previous context defined. :[font = input; initialization; ] *) EndPackage[] Null (* :[font = input; ] Clear[Draw] ^*)