Attribute VB_Name = "Module2" '******************************************************************** '* FRACTAL CURVES * '* ---------------------------------------------------------------- * '* This program generates a fractal curve using the formula: * '* x' = x(x2-x1) - y(y2-y1) + x1 * '* y' = x(y2-y1) + y(x2-x1) + y1 * '* using a basis composed of segments (such as a single segment, a * '* square, a triangle etc.) forming a closed figure, and a genera- * '* trix simple open figure, such as two bits of line at 60°. * '* The basis is memorized by its summit coordinates stored in two * '* tables Xbasis and Ybasis. The generatrix is stored in the same * '* way in tables Xgen and Ygen. Also generates a H Fractal. * '* ---------------------------------------------------------------- * '* REFERENCE: * '* "Graphisme dans le plan et dans l'espace avec Turbo-Pascal 4.0 * '* By R. Dony - MASSON, Paris 1990" [BIBLI 12]. * '* * '* Visual Basic 4 Release By J-P Moreau, Paris. * '******************************************************************** DefInt I-N DefDbl A-H, O-Z Const limite = 4096 Dim XBase(10), YBase(10), XGen(10), YGen(10) Dim Xfract(limite), Yfract(limite) Dim Example As Integer Dim order As Integer Dim PointsBase As Integer Dim PointsGen As Integer Dim A As Double Dim f1 As Double Dim f2 As Double Dim f3 As Double Dim f4 As Double Dim NomCourbe As String ' specific HFractal Dim X1(21), Y1(21), X2(21), Y2(21), X3(21), Y3(21), X4(21), Y4(21) Sub Data() Example = Val(Form1.Text1) Form1.Cls If Example = 1 Then NomCourbe = "Von Koch's Triangular Snowflakes" PointsBase = 3 XBase(0) = 1: YBase(0) = 0 XBase(1) = -0.5: YBase(1) = 0.866025 XBase(2) = -0.5: YBase(2) = -0.866025 XBase(3) = 1: YBase(3) = 0 PointsGen = 5 XGen(0) = 0: YGen(0) = 0 XGen(1) = 0.3333: YGen(1) = 0 XGen(2) = 0.5: YGen(2) = 0.2887 XGen(3) = 0.6666: YGen(3) = 0 XGen(4) = 1: YGen(4) = 0 f1 = -1.1: f2 = 1.1: f3 = -1.1: f4 = 1.1 order = Val(Form1.Text2) If order > 6 Then order = 6 If order < 1 Then order = 1 ElseIf Example = 2 Then NomCourbe = "Example #2" PointsBase = 5 XBase(0) = 0#: YBase(0) = 0# XBase(1) = 0#: YBase(1) = 1# XBase(2) = 1#: YBase(2) = 1# XBase(3) = 1#: YBase(3) = 0# XBase(4) = 0#: YBase(4) = 0# PointsGen = 3 XGen(0) = 0#: YGen(0) = 0# XGen(1) = 0.5: YGen(1) = 0.5 XGen(2) = 1#: YGen(2) = 0# f1 = -1.1: f2 = 2.1: f3 = -1.1: f4 = 2.25 order = Val(Form1.Text2) If order > 12 Then order = 12 If order < 1 Then order = 1 ElseIf Example = 3 Then NomCourbe = "Example #3" PointsBase = 5 XBase(0) = 0#: YBase(0) = 0# XBase(1) = 0#: YBase(1) = 1# XBase(2) = 1#: YBase(2) = 1# XBase(3) = 1#: YBase(3) = 0# XBase(4) = 0#: YBase(4) = 0# PointsGen = 5 XGen(0) = 0: YGen(0) = 0 XGen(1) = 0.4: YGen(1) = 0 XGen(2) = 0.5: YGen(2) = 0.4 XGen(3) = 0.6: YGen(3) = 0 XGen(4) = 1: YGen(4) = 0 f1 = -0.5: f2 = 1.5: f3 = -0.5: f4 = 1.6 order = Val(Form1.Text2) If order > 6 Then order = 6 If order < 1 Then order = 1 ElseIf Example = 4 Then NomCourbe = "H Fractal" f1 = -1: f2 = 1: f3 = -1: f4 = 1 order = Val(Form1.Text2) If order > 8 Then order = 8 If order < 1 Then order = 1 Fenetre f1, f2, f3, f4 Cloture 100, MaxX - 100, 150, MaxY - 100 Bordure End If End Sub Sub CalculateCurve(O As Integer, B As Integer, G As Integer) Dim aux1 As Integer Dim aux2 As Integer Dim X1 As Double Dim Y1 As Double Xfract(0) = 0 Yfract(0) = 0 Xfract(G ^ O) = 1 Yfract(G ^ O) = 0 For i = 0 To O - 1 aux1 = G ^ (O - i) aux2 = G ^ (O - i - 1) j = 0 While j < G ^ O m1 = j + aux1 X1 = Xfract(m1) - Xfract(j) Y1 = Yfract(m1) - Yfract(j) For k = 1 To G - 1 m2 = j + k * aux2 Xfract(m2) = X1 * XGen(k) - Y1 * YGen(k) + Xfract(j) Yfract(m2) = Y1 * XGen(k) + X1 * YGen(k) + Yfract(j) Next k j = j + aux1 Wend Next i End Sub Sub DrawBase() Form1.ForeColor = RGB(255, 0, 0) 'red pen Fenetre -2, 2, -2, 2 Cloture 10, Int(0.33 * (MaxX + 1)), Int(0.53 * (MaxY + 1)), MaxY - 10 Bordure MoveXY XBase(0), YBase(0) For i = 1 To PointsBase LineXY XBase(i), YBase(i) Next i Display 150, 150, "Base" End Sub Sub DrawGeneratrix() r = -0.1 Fenetre -1, 2, -1.5, 1.5 Cloture 10, Int(0.33 * (MaxX + 1)), 20, Int(0.51 * (MaxY + 1)) Bordure MoveXY r + XGen(0), r + YGen(0) For i = 1 To PointsGen - 1 LineXY r + XGen(i), r + YGen(i) Next i Display 150, 4300, "Generatrix" End Sub Sub DrawCurve(O As Integer, B As Integer, G As Integer) Dim nom As String Form1.ForeColor = RGB(0, 0, 255) 'blue pen Fenetre f1, f2, f3, f4 nom = NomCourbe + " Order = " + Str\$(order) ix = (MaxX - 8 * Len(nom)) / 2 Display ix, 150, nom Cloture Int(0.34 * (MaxX + 1)), MaxX - 13, 20, MaxY - 10 Bordure MoveXY XBase(0), YBase(0) For m = 0 To B - 1 diff1 = XBase(m + 1) - XBase(m) diff2 = YBase(m + 1) - YBase(m) For n = 0 To (G ^ O) - 1 xx = diff1 * Xfract(n) - diff2 * Yfract(n) + XBase(m) yy = diff2 * Xfract(n) + diff1 * Yfract(n) + YBase(m) LineXY xx, yy Next n Next m End Sub 'called by DrawHFractal Sub DrawSegments(S As Integer) For j = S To order x = X1(j - 1) y = Y1(j - 1) B = A ^ j c = A * B * 1.5 X1(j) = x + B: Y1(j) = y + c X2(j) = x + B: Y2(j) = y - c X3(j) = x - B: Y3(j) = y + c X4(j) = x - B: Y4(j) = y - c MoveXY x - B, y: LineXY x + B, y MoveXY X1(j), Y1(j): LineXY X2(j), Y2(j) MoveXY X3(j), Y3(j): LineXY X4(j), Y4(j) Next j End Sub Sub DrawHFractal() 'option #4 Dim S As Integer Dim nom As String A = 0.5 X1(1) = 0 Y1(1) = 0 S = 1 Form1.ForeColor = RGB(0, 0, 255) 'Blue pen DrawSegments S For m = 1 To 4 ^ (order - 1) - 1 n = m S = order While (n Mod 4) = 0 n = n / 4 S = S - 1 Wend X1(S - 1) = X2(S - 1): X2(S - 1) = X3(S - 1) X3(S - 1) = X4(S - 1): Y1(S - 1) = Y2(S - 1) Y2(S - 1) = Y3(S - 1): Y3(S - 1) = Y4(S - 1) DrawSegments S Next m nom = NomCourbe + " Order = " + Str\$(order) ix = ((MaxX - 8 * Len(nom)) / 2) - 1250 Display ix, 250, nom End Sub ' main subroutine Sub Exec_Fractal() 'client drawing zone in pixels MaxX = 12200 MaxY = 8500 Data If Example < 4 Then CalculateCurve order, PointsBase, PointsGen - 1 DrawBase DrawGeneratrix DrawCurve order, PointsBase, PointsGen - 1 Else DrawHFractal End If End Sub 'end of file fractal.bas