Attribute VB_Name = "Module2" '********************************************************** '* Program to demonstrate Apollonius circles and clipping * '* capability of Module Gr2D.bas * '* * '* Visual Basic 4.0 Release By J-P Moreau, Paris * '* (www.jpmoreau.fr) * '* ------------------------------------------------------ * '* DESCRIPTION: At each step, the program: * '* 1. randomly defines 3 circles so that they are at * '* least partially visible and each one is tangent * '* to the other two. * '* 2. recursively draws all the internal (apollonius) * '* circles until radius is to small, using a fast * '* procedure to draw circles. * '* ------------------------------------------------------ * '* * '* NOTE: The print option is not implemented here. * '********************************************************** DefDbl A-H, O-Z DefInt I-N 'A circle is defined by a table C(3), where C(1),C(2) 'are the center coordinates, and C(3) = 1 / Radius. Public Error2D As Boolean Function Dist2D(A(), B()) As Double 'Calculate the distance between two points A(2),B(2) Dim V(2) As Double Call GetVector2D(A, B, V) Dist2D = XNorm2D(V) End Function Sub GetVector2D(A(), B(), V()) 'Get 2D vector from point A to point B V(1) = B(1) - A(1) V(2) = B(2) - A(2) End Sub Function horsLimites(C()) As Boolean 'returns True if circle is not entirely visible r = 1 / C(3) horsLimites = True If (x < X_min) And (r < X_min - x) Then Exit Function If (y < Y_min) And (r < Y_min - y) Then Exit Function If (x > X_max) And (r < x - X_max) Then Exit Function If (y > Y_max) And (r < y - Y_max) Then Exit Function horsLimites = False End Function 'returns the internal circle to 3 given tangent circles Sub CercleInterne(c1(), c2(), c3(), Co()) Dim V2(2) As Double Dim V3(2) As Double Dim eps As Double, u As Double, vv As Double Dim d As Double eps = 0.0000000001 If c1(3) > c2(3) Then For i = 1 To 3 Co(i) = c1(i): c1(i) = c2(i): c2(i) = Co(i) Next i End If If c2(3) > c3(3) Then For i = 1 To 3 Co(i) = c2(i): c2(i) = c3(i): c3(i) = Co(i) Next i End If Call GetVector2D(c1, c2, V2) Call GetVector2D(c1, c3, V3) d = V2(1) * V3(2) - V2(2) * V3(1) If Abs(d) < eps Then erreur2D = True Else erreur2D = False End If If erreur2D = True Then Exit Sub u = Sqr(c3(3)) * Sqr(c1(3) + c2(3) + c1(3) * (c2(3) / c3(3))) Co(3) = c1(3) + c2(3) + c3(3) + 2# * u u = (1 + c2(3) / c1(3) + (c2(3) - c1(3)) / Co(3)) / c1(3) / c2(3) vv = (1 + c3(3) / c1(3) + (c3(3) - c1(3)) / Co(3)) / c1(3) / c3(3) 'centre.x:=c1.centre.x+(u*V3.y-V2.y*v)/d; Co(1) = c1(1) + (u * V3(2) - V2(2) * vv) / d 'centre.y:=c1.centre.y+(v*V2.x-V3.x*u)/d Co(2) = c1(2) + (vv * V2(1) - V3(1) * u) / d End Sub 'draw a given circle using the fast subroutine Circle1 'defined in module Gr2D Sub traceCercle(C()) cx = C(1): cy = C(2): r = 1# / C(3) Circle1 cx, cy, r, True End Sub 'Recursive subroutine to draw all the visible internal 'circles until size is too small} Sub TraceInterne(c1(), c2(), c3()) Dim h11 As Boolean Dim h12 As Boolean Dim h13 As Boolean Dim Co(3) 'circle h11 = horsLimites(c1): h12 = horsLimites(c2) If h11 And h12 Then Exit Sub h13 = horsLimites(c3) If h13 And (h11 Or h12) Then Exit Sub If c1(3) + c2(3) + c3(3) < 500 Then Call CercleInterne(c1, c2, c3, Co) Call traceCercle(Co) Call TraceInterne(c1, c2, Co) Call TraceInterne(c1, c3, Co) Call TraceInterne(c2, c3, Co) End If End Sub '*********************************************************** '* INPUTS: * '* Circle c1 defined by center and 1/radius * '* Circle c2 defined by center, radius t.b.d. * '* Circle c3 defined by 1/radius, center t.b.d. * '* OUTPUTS: * '* Circle c2 with 1/radius defined * '* Circle c3 with center defined * '* so that each circle is tangent to the other * '* two. * '* ------------------------------------------------------- * '* NOTE: t.b.d. means To be defined. * '*********************************************************** Sub troisiemeCercle(c1(), c2(), c3()) Dim V(2) As Double '2D vector C = 1# / Dist2D(c1, c2) If C >= c1(3) Then Error2D = True Else Error2D = False End If x = 1# For i = 1 To 12000 x = x + Sin(x) Next i If Error2D Then Exit Sub A = C / c1(3): B = 1 - A: c2(3) = C / B Call GetVector2D(c1, c2, V) C = C / c3(3): A = A + C: B = B + C C = (A * A - B * B + 1#) / 2# A = Sqr(A * A - C * C) c3(1) = c1(1): c3(2) = c1(2) x = c3(1): y = c3(2) c3(1) = x + V(1) * C + A * V(2) c3(2) = y + V(2) * C - A * V(1) End Sub 'main subroutine (called by button of main form 'uses Module Gr2D.bas Sub Exec_Apollo() Dim c1(3), c2(3), c3(3) 'three circles Form1.Cls Randomize Timer 'define physical window X_min = -0.6: Y_min = -0.45: X_max = 0.6: Y_max = 0.45 Call Fenetre(X_min, X_max, Y_min, Y_max) 'define window in pixels Call Cloture(500, MaxX - 25, 100, MaxY - 250) 'additional caption Display 700, 400, "APOLLONIUS CIRCLES" 'draw axes Ox, Oy Call Axes 'draw grid with steps 0.1 and 0.05 Call Grid(0.1, 0.05) 'graduate axes with steps 0.2 and 0.1 Call Graduate(0.2, 0.1) 'draw a border around graph Call Bordure 'main random loop Do 'define first random circle c1(1) = Rnd(1) - 1#: c1(2) = 0.5 * Rnd(1) - 1.25 c1(3) = Rnd(1) + 0.3 'define center of 2nd circle c2(1) = Rnd(1) - 1#: c2(2) = 0.5 * Rnd(1) + 0.5 'define curbature of 3rd circle c3(3) = Rnd(1) + 0.3 'seek center of third circle Call troisiemeCercle(c1, c2, c3) Loop Until Error2D = False 'draw the three tangent circles traceCercle c1 traceCercle c2 traceCercle c3 'recursively draw all internal circles TraceInterne c1, c2, c3 End Sub Function XNorm2D(V()) As Double 'returns the length of a 2D vector x = Abs(V(1)) y = Abs(V(2)) If x < y Then temp = y y = x x = temp End If If x > 0.0000000001 Then XNorm2D = x * Sqr(1# + (y / x) ^ 2) Else XNorm2D = 0# End If End Function