Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH10/SRC/FRACTAL.FRM

Visual Basic Form | 1996-05-02 | 16.7 KB | 561 lines

VERSION 4.00
Begin VB.Form FractalForm
   Appearance      =   0  'Flat
   BackColor       =   &H00C0C0C0&
   Caption         =   "Fractal Surfaces"
   ClientHeight    =   5700
   ClientLeft      =   300
   ClientTop       =   855
   ClientWidth     =   9090
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   1
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   6390
   KeyPreview      =   -1  'True
   Left            =   240
   LinkTopic       =   "Form1"
   ScaleHeight     =   380
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   606
   Top             =   225
   Width           =   9210
   Begin VB.TextBox DyText
      Height          =   285
      Left            =   8280
      TabIndex        =   18
      Text            =   "0.15"
      Top             =   4920
      Width           =   495
   End
   Begin VB.TextBox LevelText
      Height          =   285
      Left            =   8280
      MaxLength       =   2
      TabIndex        =   17
      Text            =   "3"
      Top             =   4560
      Width           =   495
   End
   Begin VB.CheckBox ShowHiddenCheck
      Caption         =   "Show Hidden Surfaces"
      Height          =   495
      Left            =   7080
      TabIndex        =   14
      Top             =   3720
      Width           =   2055
   End
   Begin VB.CheckBox ShowAxesCheck
      Caption         =   "Show Axes"
      Height          =   255
      Left            =   7080
      TabIndex        =   13
      Top             =   3360
      Width           =   2055
   End
   Begin VB.TextBox PhiText
      Height          =   285
      Left            =   3600
      TabIndex        =   12
      Text            =   "0.1570"
      Top             =   5400
      Width           =   855
   End
   Begin VB.TextBox ThetaText
      Height          =   285
      Left            =   2040
      TabIndex        =   10
      Text            =   "0.6283"
      Top             =   5400
      Width           =   855
   End
   Begin VB.TextBox RText
      Height          =   285
      Left            =   480
      TabIndex        =   8
      Text            =   "10"
      Top             =   5400
      Width           =   855
   End
   Begin VB.OptionButton Choice
      Caption         =   "Random"
      Height          =   255
      Index           =   5
      Left            =   7080
      TabIndex        =   7
      Top             =   1800
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Rugged Ridge"
      Height          =   255
      Index           =   4
      Left            =   7080
      TabIndex        =   6
      Top             =   1440
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Peaked Ridge"
      Height          =   255
      Index           =   3
      Left            =   7080
      TabIndex        =   5
      Top             =   1080
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Ridge"
      Height          =   255
      Index           =   2
      Left            =   7080
      TabIndex        =   4
      Top             =   720
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Hill"
      Height          =   255
      Index           =   1
      Left            =   7080
      TabIndex        =   3
      Top             =   360
      Width           =   2055
   End
   Begin VB.OptionButton Choice
      Caption         =   "Mountain"
      Height          =   255
      Index           =   0
      Left            =   7080
      TabIndex        =   2
      Top             =   0
      Value           =   -1  'True
      Width           =   2055
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      Height          =   5295
      Left            =   0
      ScaleHeight     =   349
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   461
      TabIndex        =   0
      Top             =   0
      Width           =   6975
   End
   Begin VB.Label Label1
      Caption         =   "Displacement"
      Height          =   255
      Index           =   4
      Left            =   7080
      TabIndex        =   16
      Top             =   4950
      Width           =   1215
   End
   Begin VB.Label Label1
      Caption         =   "Level"
      Height          =   255
      Index           =   3
      Left            =   7080
      TabIndex        =   15
      Top             =   4590
      Width           =   1215
   End
   Begin MSComDlg.CommonDialog LoadDialog
      Left            =   5880
      Top             =   5280
      _version        =   65536
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
      cancelerror     =   -1  'True
   End
   Begin VB.Label Label1
      Caption         =   "Phi"
      Height          =   255
      Index           =   2
      Left            =   3240
      TabIndex        =   11
      Top             =   5400
      Width           =   375
   End
   Begin VB.Label Label1
      Caption         =   "Theta"
      Height          =   255
      Index           =   1
      Left            =   1440
      TabIndex        =   9
      Top             =   5400
      Width           =   495
   End
   Begin VB.Label Label1
      Caption         =   "R"
      Height          =   255
      Index           =   0
      Left            =   240
      TabIndex        =   1
      Top             =   5400
      Width           =   255
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuFileSaveAs
         Caption         =   "&Save As..."
         Shortcut        =   ^A
      End
      Begin VB.Menu mnuFileSep
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "FractalForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
' Location of viewing eye.
Dim EyeR As Single
Dim EyeTheta As Single
Dim EyePhi As Single
Const Dtheta = PI / 20
Const Dphi = PI / 20
Const Dr = 1
' Location of focus point.
Const FocusX = 0#
Const FocusY = 0#
Const FocusZ = 0#
Dim Projector(1 To 4, 1 To 4) As Single
Dim ThePicture As ObjPicture
Dim TheGrid As ObjFractalGrid
Dim ShowingParameters As Boolean
Dim ChoiceNum As Integer
' ************************************************
' Turn hidden surfaces on or off.
' ************************************************
Private Sub ShowHiddenCheck_Click()
    TheGrid.ShowHidden = (ShowHiddenCheck.value = vbChecked)
    DrawData Pict
    Pict.SetFocus
End Sub
' *******************************************************
' Rotate the points in the cube and draw the cube.
' *******************************************************
Private Sub DrawData(pic As Object)
Dim x As Single
Dim y As Single
Dim z As Single
Dim S(1 To 4, 1 To 4) As Single
Dim t(1 To 4, 1 To 4) As Single
Dim ST(1 To 4, 1 To 4) As Single
Dim PST(1 To 4, 1 To 4) As Single
    MousePointer = vbHourglass
    Refresh
    ' Prevent overflow errors when drawing lines
    ' too far out of bounds.
    On Error Resume Next
    ' Scale and translate so it looks OK in pixels.
    m3Scale S, 35, -35, 1
    m3Translate t, 230, 175, 0
    m3MatMultiplyFull ST, S, t
    m3MatMultiplyFull PST, Projector, ST
    ' Transform the points.
    ThePicture.ApplyFull PST
    ' Display the data.
    pic.Cls
    ThePicture.Draw pic, EyeR
    pic.Refresh
    ' Display the viewnig parameters.
    ShowViewingParameters
    MousePointer = vbDefault
End Sub
Sub ShowViewingParameters()
    ShowingParameters = True
    RText.Text = Format$(EyeR, "0.0000")
    ThetaText.Text = Format$(EyeTheta, "0.0000")
    PhiText.Text = Format$(EyePhi, "0.0000")
    RText.Refresh
    ThetaText.Refresh
    PhiText.Refresh
    ShowingParameters = False
End Sub
Private Sub Choice_Click(Index As Integer)
    ChoiceNum = Index
    CreateData (ShowAxesCheck.value = vbChecked)
    DrawData Pict
    Pict.SetFocus
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyLeft
            EyeTheta = EyeTheta - Dtheta

        Case vbKeyRight
            EyeTheta = EyeTheta + Dtheta

        Case vbKeyUp
            EyePhi = EyePhi - Dphi

        Case vbKeyDown
            EyePhi = EyePhi + Dphi

        Case Else
            Exit Sub
    End Select
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case Asc("+")
            EyeR = EyeR + Dr

        Case Asc("-")
            EyeR = EyeR - Dr

        Case Else
            Exit Sub
    End Select
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub
Private Sub Form_Load()
    Randomize
    ' Initialize the eye position.
    EyeR = 10
    EyeTheta = PI * 0.2
    EyePhi = PI * 0.1
    ' Initialize the projection transformation.
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    ' Create the data.
    CreateData (ShowAxesCheck.value = vbChecked)
    ' Project and draw the data.
    Me.Show
    DrawData Pict
End Sub
' ************************************************
' Create the surface.
' ************************************************
Sub CreateData(show_axes As Boolean)
Const Xmin = -5
Const Zmin = -5
Const Dx = 1
Const Dz = 1
Const NumX = -2 * Xmin / Dx
Const NumZ = -2 * Zmin / Dz
Const Amp = 0.25
Const Per = 2 * PI / 4
Const Amp2 = 1
Const Per2 = 2 * PI / 16
Const Amp3 = 2
Dim axis As ObjPolyline
Dim i As Integer
Dim j As Integer
Dim x As Single
Dim y As Single
Dim z As Single
Dim D As Single
Dim d2 As Single
Dim R2 As Single
Dim x1 As Single
Dim z1 As Single
Dim x2 As Single
Dim z2 As Single
Dim level As Integer
Dim Dy As Single
    MousePointer = vbHourglass
    Refresh
    Set ThePicture = New ObjPicture
    Set TheGrid = New ObjFractalGrid
    TheGrid.SetBounds Xmin, Dx, NumX, Zmin, Dz, NumZ
    ThePicture.objects.Add TheGrid
    TheGrid.ShowHidden = (ShowHiddenCheck.value = vbChecked)
    If show_axes Then
        Set axis = New ObjPolyline
        ThePicture.objects.Add axis
        axis.AddSegment 0, 0, 0, 5.5, 0, 0
        axis.AddSegment 0, 0, 0, 0, 3, 0
        axis.AddSegment 0, 0, 0, 0, 0, 5.5
    End If
    R2 = (Xmin + 3 * Dx) * (Xmin + 3 * Dx)
    x1 = PI * Rnd
    x = Xmin
    For i = 1 To NumX
        z = Zmin
        For j = 1 To NumZ
            Select Case ChoiceNum
                Case 0  ' Mountain.
                    x1 = x + 0.5
                    D = 2 * (Amp3 - Sqr(x1 * x1 + z * z))
                    x2 = x - 0.5
                    d2 = 2 * (Amp3 - Sqr(x2 * x2 + z * z)) - 0.5
                    If D < d2 Then D = d2
                    If D < -Amp3 Then D = -Amp3
                    y = D

                Case 1  ' Hill.
                    R2 = 9
                    D = x * x + z * z
                    If D >= R2 Then
                        y = 0
                    ElseIf z < 0 Then
                        y = 0.75 * Sqr(R2 - D)
                    Else
                        y = 0.75 * Sqr(R2 - D) * (3 - z) / 3
                    End If

                Case 2  ' Ridge.
                    y = 2 * Cos(2 * PI / 10 * z) * (5 - Abs(z)) / 5 + 0.5 * Rnd
                Case 3  ' Peaked Ridge.
                    y = 2 * Cos(2 * PI / 10 * z) * (5 - Abs(z)) / 5 + 0.25 * Sin(2 * x + x1) + 0.25 * Sin(1# * x + x1) + 0.5 * Rnd

                Case 4  ' Rugged ridge.
                    y = 2 * Cos(2 * PI / 10 * z) * (5 - Abs(z)) / 5 + Rnd
                    If i = 1 Or i = NumX Or j = 1 Or j = NumX Then
                        ' Keep the edges down a bit.
                        y = y - 0.5 * Rnd
                    End If

                Case 5  ' Random.
                    y = Rnd

            End Select

            TheGrid.SetValue x, y, z
            z = z + Dz
        Next j
        x = x + Dx
    Next i
    If Not IsNumeric(LevelText.Text) Then _
        LevelText.Text = "4"
    level = CInt(LevelText.Text)
    If Not IsNumeric(DyText.Text) Then _
        DyText.Text = "0.25"
    Dy = CSng(DyText.Text)
    TheGrid.GenerateSurface level, Dy
    MousePointer = vbDefault
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub
Private Sub mnuFileLoad_Click()
Dim fname As String
Dim filenum As Integer
Dim txt As String
Dim Xmin As Single
Dim ymin As Single
Dim Xmax As Single
Dim ymax As Single
    ' Allow the user to pick a file.
    On Error Resume Next
    LoadDialog.filename = "*.APF"
    LoadDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Unload LoadDialog
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Unload LoadDialog
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    fname = LoadDialog.filename
    LoadDialog.InitDir = Left$(fname, Len(fname) _
        - Len(LoadDialog.FileTitle) - 1)
    ' Clear the picture.
    Set ThePicture = Nothing
    ' Open the file.
    filenum = FreeFile
    Open fname For Input As #filenum
    ' Make sure it's an Object Picture File.
    Input #filenum, txt
    If txt <> "3D APF PICTURE" Then
        Close filenum
        Beep
        MsgBox "Error reading file """ & fname & """.", , vbExclamation
        Exit Sub
    End If
    ' Read the picture.
    Set ThePicture = New ObjPicture
    ThePicture.FileInput filenum
    If ThePicture.objects(1).ObjectType = "FRACTALGRID" Then
        Set TheGrid = ThePicture.objects(1)
        TheGrid.ShowHidden = (ShowHiddenCheck.value = vbChecked)
    End If
    ' Close the file.
    Close filenum
    ' Refresh the display.
    DrawData Pict
    ' Deselect all the option buttons.
    For ChoiceNum = 0 To 5
        If Choice(ChoiceNum).value Then _
            Choice(ChoiceNum).value = False
    Next ChoiceNum
End Sub
Private Sub mnuFileSaveAs_Click()
Dim fname As String
Dim filenum As Integer
    ' Allow the user to pick a file.
    On Error Resume Next
    LoadDialog.filename = "*.APF"
    LoadDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
    LoadDialog.ShowSave
    If Err.Number = cdlCancel Then
        Unload LoadDialog
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Unload LoadDialog
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    fname = LoadDialog.filename
    LoadDialog.InitDir = Left$(fname, Len(fname) _
        - Len(LoadDialog.FileTitle) - 1)
    ' Open the file.
    MousePointer = vbHourglass
    DoEvents
    filenum = FreeFile
    Open fname For Output As #filenum
    ' Write the picture.
    ThePicture.FileWrite filenum
    ' Close the file.
    Close filenum
    MousePointer = vbDefault
End Sub
Private Sub PhiText_Change()
    If ShowingParameters Then Exit Sub
    EyePhi = CSng(PhiText.Text)
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub
Private Sub RText_Change()
    If ShowingParameters Then Exit Sub
    EyeR = CSng(RText.Text)
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub
Private Sub ShowAxesCheck_Click()
    CreateData (ShowAxesCheck.value = vbChecked)
    DrawData Pict
    Pict.SetFocus
End Sub
Private Sub ThetaText_Change()
    If ShowingParameters Then Exit Sub
    EyeTheta = CSng(ThetaText.Text)
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub