Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH8/SRC/MAND.FRM

Visual Basic Form | 1996-05-02 | 19.4 KB | 626 lines

VERSION 4.00
Begin VB.Form MandelbrotForm
   Caption         =   "Mandelbrot"
   ClientHeight    =   3810
   ClientLeft      =   2370
   ClientTop       =   1320
   ClientWidth     =   3810
   Height          =   4500
   Left            =   2310
   LinkTopic       =   "Form1"
   ScaleHeight     =   254
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   254
   Top             =   690
   Width           =   3930
   Begin VB.PictureBox Canvas
      AutoRedraw      =   -1  'True
      BackColor       =   &H00000000&
      DrawMode        =   6  'Mask Pen Not
      Height          =   3810
      Left            =   0
      MousePointer    =   2  'Cross
      Picture         =   "MAND.frx":0000
      ScaleHeight     =   250
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   250
      TabIndex        =   0
      Top             =   0
      Width           =   3810
   End
   Begin MSComDlg.CommonDialog FileDialog
      Left            =   240
      Top             =   3600
      _version        =   65536
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
      cancelerror     =   -1  'True
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      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
   Begin VB.Menu mnuScaleMnu
      Caption         =   "&Scale"
      Begin VB.Menu mnuScale
         Caption         =   "x&2"
         Index           =   2
      End
      Begin VB.Menu mnuScale
         Caption         =   "x&4"
         Index           =   4
      End
      Begin VB.Menu mnuScale
         Caption         =   "x&8"
         Index           =   8
      End
      Begin VB.Menu mnuScaleFull
         Caption         =   "&Full Scale"
      End
   End
   Begin VB.Menu mnuOpt
      Caption         =   "&Options"
      Begin VB.Menu mnuOptIter
         Caption         =   "&Iterations..."
      End
      Begin VB.Menu mnuOptColors
         Caption         =   "&Colors..."
      End
   End
   Begin VB.Menu mnuMovie
      Caption         =   "&Movie"
      Begin VB.Menu mnuMovieCreate
         Caption         =   "&Create Movie..."
      End
   End
Attribute VB_Name = "MandelbrotForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim DrawingBox As Boolean
Dim StartX As Single
Dim StartY As Single
Dim CurX As Single
Dim CurY As Single
Dim Xmin As Single
Dim Xmax As Single
Dim Ymin As Single
Dim Ymax As Single
Dim MaxIter As Integer
Dim NumClrs As Integer
Dim ok_clr() As Integer
' ************************************************
' Return the number of colors in use.
' ************************************************
Property Get NumColors() As Integer
    NumColors = NumClrs
End Property
' ************************************************
' Return the value of the indicated color.
' ************************************************
Property Get OkClr(index As Integer) As Integer
    OkClr = ok_clr(index)
End Property
' ***********************************************
' Make Canvas's palette contain the system static
' colors so the colors are saved to files with
' the image.
' ***********************************************
Sub PreparePalette(pic As Control)
Dim SysPalSize As Integer
Dim NumStaticColors As Integer
Dim StaticColor1 As Integer
Dim StaticColor2 As Integer
Dim offset As Integer
Dim LogPal As Integer
Dim palentry(0 To 255) As PALETTEENTRY
Dim sys(0 To 255) As PALETTEENTRY
Dim i As Integer
    ' Make sure the screen supports palettes.
    If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
        Beep
        MsgBox "This monitor does not support palettes.", _
            vbCritical
        End
    End If
    ' Get system palette size and # static colors.
    SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
    NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
    StaticColor1 = NumStaticColors \ 2 - 1
    StaticColor2 = SysPalSize - NumStaticColors \ 2
    ' Make sure pic has the foreground palette.
    pic.ZOrder
    i = RealizePalette(pic.hdc)
    DoEvents
    ' Get the system palette entries.
    i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))

    ' Make the logical palette as big as possible.
    LogPal = pic.Picture.hPal
    If ResizePalette(LogPal, NumStaticColors) = 0 Then
        Beep
        MsgBox "Error resizing logical palette.", _
            vbExclamation
        Exit Sub
    End If
    ' Insert the system static colors.
    For i = 0 To StaticColor1
        palentry(i) = sys(i)
    Next i
    offset = StaticColor2 - StaticColor1 - 1
    For i = StaticColor2 To 255
        palentry(i - offset) = sys(i)
    Next i
    i = SetPaletteEntries(LogPal, 0, NumStaticColors, palentry(0))
    ' Realize the new palette.
    i = RealizePalette(pic.hdc)
End Sub
' ************************************************
' Adjust the aspect ratio of the selected
' coordinates so they fit the window properly.
' ************************************************
Sub AdjustAspect()
Dim want_aspect As Single
Dim canvas_aspect As Single
Dim hgt As Single
Dim wid As Single
Dim mid As Single
    want_aspect = (Ymax - Ymin) / (Xmax - Xmin)
    canvas_aspect = Canvas.ScaleHeight / Canvas.ScaleWidth
    If want_aspect > canvas_aspect Then
        ' The selected area is too tall and thin.
        ' Make it wider.
        wid = (Ymax - Ymin) / canvas_aspect
        mid = (Xmin + Xmax) / 2
        Xmin = mid - wid / 2
        Xmax = mid + wid / 2
    Else
        ' The selected area is too short and wide.
        ' Make it taller.
        hgt = (Xmax - Xmin) * canvas_aspect
        mid = (Ymin + Ymax) / 2
        Ymin = mid - hgt / 2
        Ymax = mid + hgt / 2
    End If
End Sub
' ************************************************
' Draw the Mandelbrot set.
' ************************************************
Sub DrawMandelbrot()
Const MAX_MAG_SQUARED = 4  ' Work until the magnitude squared > 4.
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim bytes() As Byte
Dim wid As Long
Dim hgt As Long
Dim clr As Long
Dim i As Integer
Dim j As Integer
Dim ReaC As Double
Dim ImaC As Double
Dim dReaC As Double
Dim dImaC As Double
Dim ReaZ As Double
Dim ImaZ As Double
Dim ReaZ2 As Double
Dim ImaZ2 As Double
    WaitStart
    AdjustAspect
    ' Get the image pixels.
    hbm = Canvas.Image
    status = GetObject(hbm, 14, bm)
    wid = bm.bmWidthBytes
    hgt = bm.bmHeight
    ReDim bytes(1 To wid, 1 To hgt)
    ' dReaC is the change in the real part
    ' (X value) for C. dImaC is the change in the
    ' imaginary part (Y value).
    dReaC = (Xmax - Xmin) / (wid - 1)
    dImaC = (Ymax - Ymin) / (hgt - 1)
    ' Calculate the values.
    ReaC = Xmin
    For i = 1 To wid
        ImaC = Ymin
        For j = 1 To hgt
            ReaZ = 0
            ImaZ = 0
            ReaZ2 = 0
            ImaZ2 = 0
            clr = 1
            Do While clr < MaxIter And _
                    ReaZ2 + ImaZ2 < MAX_MAG_SQUARED
                ' Calculate Z(clr).
                ReaZ2 = ReaZ * ReaZ
                ImaZ2 = ImaZ * ImaZ
                ImaZ = 2 * ImaZ * ReaZ + ImaC
                ReaZ = ReaZ2 - ImaZ2 + ReaC
                clr = clr + 1
            Loop
            bytes(i, j) = ok_clr(clr Mod NumClrs)
            ImaC = ImaC + dImaC
        Next j
        ReaC = ReaC + dReaC

        ' Let the user know we're not dead.
'@        If i Mod 10 = 0 Then
'@            status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
'@            Canvas.Refresh
'@        End If
    Next i
    ' Update the image.
    status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
    Canvas.Refresh
    Caption = "Mandelbrot (" & Format$(Xmin) & ", " & Format$(Ymin) & ")-(" & Format$(Xmax) & ", " & Format$(Ymax) & ")"
    WaitEnd
End Sub
' ************************************************
' Fill in an array with the indexes of the static
' colors we want to use.
' ************************************************
Sub InitColors()
    NumClrs = 16
    ReDim ok_clr(0 To NumClrs - 1)
    ok_clr(0) = 0       ' Black
    ok_clr(1) = 1       ' Dark red
    ok_clr(2) = 2       ' Dark green
    ok_clr(3) = 3       ' Dark yellow
    ok_clr(4) = 4       ' Dark blue
    ok_clr(5) = 5       ' Dark magenta
    ok_clr(6) = 6       ' Dark cyan
'   ok_clr( ) = 7       ' Light gray
'   ok_clr( ) = 8       ' Money green
    ok_clr(7) = 9       ' Sky blue
    ok_clr(8) = 246     ' Cream
'   ok_clr( ) = 247     ' Light gray
'   ok_clr( ) = 248     ' Medium gray
    ok_clr(9) = 249     ' Red
    ok_clr(10) = 250    ' Green
    ok_clr(11) = 251    ' Yellow
    ok_clr(12) = 252    ' Blue
    ok_clr(13) = 253    ' Magenta
    ok_clr(14) = 254    ' Cyan
    ok_clr(15) = 255    ' White
End Sub
' ************************************************
' Start a rubberband box to select a zoom area.
' ************************************************
Private Sub Canvas_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    DrawingBox = True
    StartX = X
    StartY = Y
    CurX = X
    CurY = Y
    Canvas.Line (StartX, StartY)-(CurX, CurY), , B
End Sub
' ************************************************
' Continue the zoom area rubberband box.
' ************************************************
Private Sub Canvas_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not DrawingBox Then Exit Sub
    Canvas.Line (StartX, StartY)-(CurX, CurY), , B
    CurX = X
    CurY = Y
    Canvas.Line (StartX, StartY)-(CurX, CurY), , B
End Sub
' ************************************************
' Zoom in on the selected area.
' ************************************************
Private Sub Canvas_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim x1 As Single
Dim x2 As Single
Dim y1 As Single
Dim y2 As Single
Dim factor As Single
    If Not DrawingBox Then Exit Sub
    DrawingBox = False
    Canvas.Line (StartX, StartY)-(CurX, CurY), , B
    CurX = X
    CurY = Y
    ' Put the coordinates in proper order.
    If CurX < StartX Then
        x1 = CurX
        x2 = StartX
    Else
        x1 = StartX
        x2 = CurX
    End If
    If x1 = x2 Then x2 = x1 + 1
    If CurY < StartY Then
        y1 = CurY
        y2 = StartY
    Else
        y1 = StartY
        y2 = CurY
    End If
    If y1 = y2 Then y2 = y1 + 1
    ' Convert screen coords into drawing coords.
    factor = (Xmax - Xmin) / Canvas.ScaleWidth
    Xmax = Xmin + x2 * factor
    Xmin = Xmin + x1 * factor
    factor = (Ymax - Ymin) / Canvas.ScaleHeight
    Ymax = Ymin + y2 * factor
    Ymin = Ymin + y1 * factor
    DrawMandelbrot
End Sub
' ************************************************
' Force Visual Basic to resize the bitmap.
' ************************************************
Private Sub Canvas_Resize()
    Canvas.Cls
End Sub
' ************************************************
' Allow the user to pick the colors in use.
' ************************************************
Private Sub mnuOptColors_Click()
Dim frm As New ColorForm
Dim i As Integer
    frm.Show vbModal
    If frm.Canceled Then Exit Sub
    ' See which colors were selected.
    NumClrs = 0
    For i = 0 To 9
        If frm.ColorCheck(i).value = vbChecked Then _
            NumClrs = NumClrs + 1
    Next i
    For i = 246 To 255
        If frm.ColorCheck(i).value = vbChecked Then _
            NumClrs = NumClrs + 1
    Next i
    ' If the user didn't pick at least 2 colors,
    ' use black and white.
    If NumClrs < 2 Then
        NumClrs = 2
        frm.ColorCheck(0).value = vbChecked
        frm.ColorCheck(255).value = vbChecked
    End If
    ' Create the ok_clr array.
    ReDim ok_clr(0 To NumClrs - 1)
    NumClrs = 0
    For i = 0 To 9
        If frm.ColorCheck(i).value = vbChecked Then
            ok_clr(NumClrs) = i
            NumClrs = NumClrs + 1
        End If
    Next i
    For i = 246 To 255
        If frm.ColorCheck(i).value = vbChecked Then
            ok_clr(NumClrs) = i
            NumClrs = NumClrs + 1
        End If
    Next i
    Unload frm
End Sub
' ***********************************************
' Load a new data file.
' ***********************************************
Private Sub mnuFileSaveAs_Click()
Dim fname As String
    ' Allow the user to pick a file.
    On Error Resume Next
    FileDialog.filename = "*.BMP"
    FileDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
    FileDialog.ShowSave
    If Err.Number = cdlCancel Then
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    fname = Trim$(FileDialog.filename)
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)
    ' Save the picture.
    SavePicture Canvas.Image, fname
End Sub
' ***********************************************
' Give the form and all the picture boxes an
' hourglass cursor.
' ***********************************************
Sub WaitStart()
    MousePointer = vbHourglass
    Canvas.MousePointer = vbHourglass
    DoEvents
End Sub
' ***********************************************
' Restore the mouse pointers for the form and all
' the picture boxes.
' ***********************************************
Sub WaitEnd()
    MousePointer = vbDefault
    Canvas.MousePointer = vbCrosshair
End Sub
' ************************************************
' Draw the initial Mandelbrot set.
' ************************************************
Private Sub Form_Load()
    Me.Show
    DoEvents
    MaxIter = 64
    ' Put the system static colors in the palette.
    PreparePalette Canvas
    ' Display the first Mandelbrot set.
    InitColors
    mnuScaleFull_Click
End Sub
Private Sub Form_Resize()
    Canvas.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub
' ************************************************
' Let the user set the maximum number of
' iterations.
' ************************************************
Private Sub mnuOptIter_Click()
Dim txt As String
Dim value As Integer
    txt = InputBox("Maximum number of iterations:", _
        "Iterations", Format$(MaxIter))
    If txt = "" Then Exit Sub
    If IsNumeric(txt) Then value = CInt(txt)
    If value > 0 Then
        MaxIter = value
    Else
        Beep
    End If
End Sub
' ************************************************
' Zoom out to full scale.
' ************************************************
Private Sub mnuScaleFull_Click()
    Xmin = -2
    Xmax = 1.2
    Ymin = -1.2
    Ymax = 1.2
    DrawMandelbrot
End Sub
' ************************************************
' Make a series of images.
' ************************************************
Private Sub MakeMovie(fname As String)
Dim num_frames As Integer
Dim frame As Integer
Dim fraction As Single  ' Amount to reduce image.
Dim xmid As Single      ' Center of image.
Dim ymid As Single
Dim wid1 As Single      ' Starting dimensions.
Dim hgt1 As Single
Dim wid2 As Single      ' Finishing dimensions.
Dim hgt2 As Single
Dim wid As Single       ' Current dimensions.
Dim hgt As Single
Dim start_time As Single
Dim stop_time As Single
Dim max_time As Single
Dim min_time As Single
Dim txt As String
Dim value As Integer
    ' See how may frames the user wants.
    txt = InputBox("Number of frames:", _
        "Frames", "20")
    If txt = "" Then Exit Sub
    If IsNumeric(txt) Then num_frames = CInt(txt)
    If num_frames < 1 Then num_frames = 20
    WaitStart
    max_time = 0
    min_time = 100000

    ' Set the center of focus and dimensions.
    xmid = (Xmin + Xmax) / 2
    ymid = (Ymin + Ymax) / 2
    wid1 = 3
    wid2 = 0.1
    ' Compute start and finish heights.
    hgt1 = wid1 * Canvas.ScaleHeight / Canvas.ScaleWidth
    hgt2 = wid2 * Canvas.ScaleHeight / Canvas.ScaleWidth
    ' Compute the amount to reduce the image for
    ' each frame.
    fraction = Exp(Log(wid2 / wid1) / num_frames)
    ' Start cranking out frames.
    wid = wid1
    hgt = hgt1
    For frame = 0 To num_frames - 1
        Caption = "Mandelbrot" & Str$(frame) & _
            "/" & Format$(num_frames - 1)

        Xmin = xmid - wid / 2
        Xmax = xmid + wid / 2
        Ymin = ymid - hgt / 2
        Ymax = ymid + hgt / 2

        start_time = Timer
        DrawMandelbrot
        stop_time = Timer

        If min_time > stop_time - start_time Then min_time = stop_time - start_time
        If max_time < stop_time - start_time Then max_time = stop_time - start_time

        SavePicture Canvas.Image, _
            fname & Format$(frame) & ".bmp"
        Beep
        DoEvents

        wid = wid * fraction
        hgt = hgt * fraction
    Next frame
    WaitEnd
    MsgBox _
        "Longest:  " & Format$(max_time, "0.00") & _
            " seconds." & vbCrLf & _
        "Shortest: " & Format$(min_time, "0.00") & _
            " seconds." & vbCrLf
End Sub
' ************************************************
' Make a series of images.
' ************************************************
Private Sub mnuMovieCreate_Click()
Dim oldtitle As String
Dim fname As String
Dim pos As Integer
    ' Allow the user to pick a file.
    On Error Resume Next
    oldtitle = FileDialog.DialogTitle
    FileDialog.DialogTitle = "Select base file name (no number)"
    FileDialog.filename = "*.BMP"
    FileDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
    FileDialog.ShowSave
    FileDialog.DialogTitle = oldtitle
    If Err.Number = cdlCancel Then
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
    fname = Trim$(FileDialog.filename)
    FileDialog.InitDir = Left$(fname, Len(fname) _
        - Len(FileDialog.FileTitle) - 1)
    ' Trim off the extension if any.
    pos = InStr(fname, ".")
    If pos > 0 Then fname = Left$(fname, pos - 1)
    ' Add a trailing underscore if needed.
    If Right$(fname, 1) <> "_" Then _
        fname = fname & "_"
    ' Make the movie.
    MakeMovie fname
End Sub
' ************************************************
' Increase the area shown by a factor of Index.
' ************************************************
Private Sub mnuScale_Click(index As Integer)
Dim size As Single
Dim mid As Single
    size = index * (Xmax - Xmin)
    If size > 3.2 Then
        mnuScaleFull_Click
        Exit Sub
    End If
    mid = (Xmin + Xmax) / 2
    Xmin = mid - size / 2
    Xmax = mid + size / 2
    size = index * (Ymax - Ymin)
    If size > 2.4 Then
        mnuScaleFull_Click
        Exit Sub
    End If
    mid = (Ymin + Ymax) / 2
    Ymin = mid - size / 2
    Ymax = mid + size / 2
    DrawMandelbrot
End Sub