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