[VB6] - Multithreading is an example of a fractal Julia.

http://www.youtube.com/watch?v=A1TqppTtjYg

Hello everyone! I really like fractals and fractal sets. Wrote several test programs, where you can generate and change the settings for different fractals. In this example, you can generate the Julia set and change all the parameters of generation (including load a palette of images). To avoid a program hangs, I generation and rendering stuck in another thread. Example does not work IDE, operates in a compiled form.

Form:

Code:

---

Option Explicit
 
' Многопоточность на примере фрактала Julia (Z^2+C)
' © Кривоус Анатолий Анатольевич (The trick), 2013
' Работает только в скомпилированном виде
 
Private Type OPENFILENAME
    lStructSize As Long
    hWndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenFilename As OPENFILENAME) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal i As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal y As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
 
Private Enum Sliders
    YOffset
    XOffset
    Scaling
    RealPart
    ImaginaryPart
End Enum
Private Enum Colors
    cBackground = 0
    cBorders = &H303030
    cSlider = &H202020
    cSelect = &H30FFFF
End Enum
Private Type Slider
    Orientation As Boolean  ' True = Вертикально
    Value As Double
    Scl As Double          ' Величина изменения
    Pos As Double
End Type
 
Private Const SliderSize As Long = 10
Private Const STILL_ACTIVE = &H103&
Private Const INFINITE = &HFFFFFFFF
Private Const x_MaxBuffer = 32768
Private Const OFN_ENABLESIZING = &H800000
Private Const OFN_EXPLORER = &H80000
 
Dim Slider(4) As Slider, IsAction As Boolean, Active As Long
Dim hFont As Long
Dim EnableUpdate As Boolean
Dim hThread As Long
Dim C As Canvas
 
Private Sub Form_Load()
    Dim i As Long
    Slider(Sliders.YOffset).Orientation = True
    Slider(Sliders.Scaling).Value = 1
    For i = 0 To UBound(Slider)
        Slider(i).Scl = 0.1
        Active = i
        DrawSlider i
    Next
    hFont = CreateFont((Me.FontSize * -20) / Screen.TwipsPerPixelY, 0, 2700, 0, Me.Font.Weight, 0, 0, 0, 204, 0, 0, 2, 0, Me.FontName)
    i = SelectObject(Me.hdc, hFont)
    Me.CurrentX = 530: Me.CurrentY = 150: Me.Print "Offset Y:"
    SelectObject Me.hdc, i
    Active = Sliders.Scaling: SliderEvent
    Active = Sliders.YOffset: SliderEvent
    EnableUpdate = True
   
    For i = 0 To 99
        modJulia.Palette(i) = RGB(i, i, i)
    Next
 
End Sub
Private Sub Form_Unload(cancel As Integer)
    ExitThread
    DeleteObject hFont
End Sub
Private Function ShowOpen() As String
    Dim N As Long
    Dim FileStruct As OPENFILENAME
   
    With FileStruct
        .hWndOwner = Me.hwnd
        .lpstrFile = String(x_MaxBuffer, 0)
        .nMaxFile = x_MaxBuffer - 1
        .lpstrFileTitle = .lpstrFile
        .nMaxFileTitle = x_MaxBuffer - 1
        .Flags = OFN_ENABLESIZING Or OFN_EXPLORER
        .lStructSize = Len(FileStruct)
        .lpstrFilter = "All supported image" & vbNullChar & "*.bmp;*.jpg;*.jpeg"
        If GetOpenFileName(FileStruct) Then
            N = InStr(1, .lpstrFile, vbNullChar)
            ShowOpen = Left$(.lpstrFile, N - 1)
        End If
    End With
End Function
Private Sub ExitThread()
    Dim Ret As Long
    If modJulia.Process Then
        modJulia.Process = False
        GetExitCodeThread hThread, Ret
        If Ret = STILL_ACTIVE Then
            WaitForSingleObject hThread, INFINITE
        End If
    End If
End Sub
Private Sub Update()
    Dim TID As Long
   
    ExitThread
   
    modJulia.iLeft = Slider(Sliders.XOffset).Value - 1 / Slider(Sliders.Scaling).Value
    modJulia.iRight = Slider(Sliders.XOffset).Value + 1 / Slider(Sliders.Scaling).Value
    modJulia.iTop = -Slider(Sliders.YOffset).Value - 1 / Slider(Sliders.Scaling).Value
    modJulia.iBottom = -Slider(Sliders.YOffset).Value + 1 / Slider(Sliders.Scaling).Value
    modJulia.Real = Slider(Sliders.RealPart).Value
    modJulia.Imaginary = Slider(Sliders.ImaginaryPart).Value
    C.hdc = picDisp.hdc
    C.Width = picDisp.ScaleWidth
    C.Height = picDisp.ScaleHeight
   
    If EnableUpdate Then
        hThread = CreateThread(ByVal 0, 0, AddressOf DrawJulia, C, 0, TID)
    End If
End Sub
Private Sub DrawSlider(ByVal Index As Sliders)
    Dim p As Long
    picSlider(Index).FillColor = Colors.cBackground
    picSlider(Index).Line (0, 0)-Step(picSlider(Index).ScaleWidth - 1, picSlider(Index).ScaleHeight - 1), Colors.cBorders, B
    If Slider(Index).Orientation Then
        p = Slider(Index).Pos * (picSlider(Index).ScaleHeight - SliderSize) \ 2 + picSlider(Index).ScaleHeight \ 2 - SliderSize \ 2
        picSlider(Index).FillColor = Colors.cSlider
        picSlider(Index).Line (3, p)-Step(picSlider(Index).ScaleWidth - 7, SliderSize), Colors.cBorders, B
    Else
        p = Slider(Index).Pos * (picSlider(Index).ScaleWidth - SliderSize) \ 2 + picSlider(Index).ScaleWidth \ 2 - SliderSize \ 2
        picSlider(Index).FillColor = Colors.cSlider
        picSlider(Index).Line (p, 3)-Step(SliderSize, picSlider(Index).ScaleHeight - 7), Colors.cBorders, B
    End If
End Sub
Private Sub lbLoadPalette_DblClick()
    Dim File As String, Img As StdPicture, DC As Long, obmp As Long, W As Long, X As Long, D As Single, i As Long, p As Long
    lbLoadPalette.ForeColor = cSelect
    File = ShowOpen()
    lbLoadPalette.ForeColor = Me.ForeColor
    If Len(File) Then
        On Error GoTo ErrorLoading
        Set Img = LoadPicture(File)
        On Error GoTo 0
        W = ScaleX(Img.Width, vbHimetric, vbPixels)
        DC = CreateCompatibleDC(Me.hdc)
        obmp = SelectObject(DC, Img.Handle)
        D = W / 100
        For i = 0 To 100
            X = i * D
            p = GetPixel(DC, X, 0)
            modJulia.Palette(i) = ((p \ &H10000) And &HFF&) Or (p And &HFF00&) Or ((p And &HFF) * &H10000)
        Next
        SelectObject DC, obmp
        DeleteDC DC
        Set Img = Nothing
        Update
    End If
    Exit Sub
ErrorLoading:
    MsgBox "Error loading image"
End Sub
 
Private Sub picDisp_Paint()
    Update
End Sub
Private Sub picSlider_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, y As Single)
    Dim p As Double
    IsAction = True
    tmrSlider.Enabled = True
    Active = Index
    If Slider(Index).Orientation Then
        Slider(Index).Pos = y / (picSlider(Index).ScaleHeight - SliderSize) * 2 - 1
    Else
        Slider(Index).Pos = X / (picSlider(Index).ScaleWidth - SliderSize) * 2 - 1
    End If
    If Abs(Slider(Index).Pos) > 1 Then Slider(Index).Pos = Sgn(Slider(Index).Pos)
    Slider(Index).Value = Slider(Index).Value + Slider(Index).Pos * Slider(Index).Scl
    SliderEvent
    DrawSlider Index
End Sub
Private Sub picSlider_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, y As Single)
    If Not IsAction Then Exit Sub
    If Slider(Index).Orientation Then
        Slider(Index).Pos = y / (picSlider(Index).ScaleHeight - SliderSize) * 2 - 1
    Else
        Slider(Index).Pos = X / (picSlider(Index).ScaleWidth - SliderSize) * 2 - 1
    End If
    If Abs(Slider(Index).Pos) > 1 Then Slider(Index).Pos = Sgn(Slider(Index).Pos)
    Slider(Index).Value = Slider(Index).Value + Slider(Index).Pos * Slider(Index).Scl
    SliderEvent
    DrawSlider Index
End Sub
Private Sub picSlider_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, y As Single)
    If IsAction Then
        IsAction = False
        tmrSlider.Enabled = False
        Slider(Index).Pos = 0
        DrawSlider Index
        SliderEvent
    End If
End Sub
Private Sub SliderEvent()
    Dim i As Long
    Select Case Active
    Case Sliders.YOffset
        i = SelectObject(Me.hdc, hFont)
        Me.Line (530, 350)-Step(-40, 120), Me.BackColor, BF
        Me.CurrentX = 530: Me.CurrentY = 350: Me.Print Format(Slider(Active).Value, "#0.00000")
        SelectObject Me.hdc, i
    Case Sliders.Scaling
        If Slider(Scaling).Value <= 0 Then Slider(Scaling).Value = 0.00000000000001
        For i = 0 To UBound(Slider)
            Select Case i
            Case Sliders.XOffset, Sliders.YOffset
                Slider(i).Scl = 1 / Slider(Scaling).Value * 0.1
            Case Sliders.RealPart, Sliders.ImaginaryPart
                Slider(i).Scl = 1 / Slider(Scaling).Value * 0.02
            End Select
        Next
        lblValue(Active).Caption = Format(Slider(Active).Value, "#0.00000")
    Case Sliders.XOffset To Sliders.ImaginaryPart
        lblValue(Active).Caption = Format(Slider(Active).Value, "#0.00000")
    End Select
    Update
End Sub
Private Sub tmrSlider_Timer()
    Slider(Active).Value = Slider(Active).Value + Slider(Active).Pos * Slider(Active).Scl
    SliderEvent
End Sub

---

Standart module:

Code:

---

Option Explicit
 
' Генерация фрактала Julia (отдельный поток)
' © Кривоус Анатолий Анатольевич (The trick), 2013
 
Public Type Canvas
    hdc As Long
    Width As Long
    Height As Long
End Type
Public Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Public Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Public Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
 
Public Palette(99) As Long
Public Process As Boolean
Public iLeft As Double, iTop As Double, iRight As Double, iBottom As Double, Real As Double, Imaginary As Double
 
Public Function DrawJulia(C As Canvas) As Long
    Dim X As Double, y As Double, Sx As Double, Sy As Double
    Dim pt As Long, Bits() As Long, bi As BITMAPINFO
    Dim lx As Long, ly As Long
   
    Process = True
   
    ReDim Bits(C.Width * C.Height - 1)
    With bi.bmiHeader
        .biBitCount = 32
        .biHeight = -C.Height
        .biWidth = C.Width
        .biPlanes = 1
        .biSize = Len(bi.bmiHeader)
        .biSizeImage = C.Width * C.Height * 4
    End With
   
    Sx = (iRight - iLeft) / (C.Width - 1)
    Sy = (iRight - iLeft) / (C.Height - 1)
    X = iLeft: y = iTop
    Process = Not Not Process
    For ly = 0 To C.Height - 1: For lx = 0 To C.Width - 1
        X = X + Sx
        Bits(pt) = Palette(Julia(X, y))
        pt = pt + 1
        If Not Process Then GoTo cancel
    Next: y = y + Sy: X = iLeft: Next
cancel:
    SetDIBitsToDevice C.hdc, 0, 0, C.Width, ly, 0, 0, 0, ly, VarPtr(Bits(0)), VarPtr(bi), 0
   
    Process = False
End Function
Private Function Julia(X As Double, y As Double) As Single
    Dim Zr As Double, Zi As Double
    Dim Cr As Double, Ci As Double
    Dim tZr As Double
    Dim Count As Long
    Dim r As Single
    Count = 0
    Zr = X: Zi = y
    Cr = Real: Ci = Imaginary
    Do While Count < 99 And r < 10
        tZr = Zr
        Zr = Zr * Zr - Zi * Zi
        Zi = tZr * Zi + Zi * tZr
        Zr = Zr + Cr
        Zi = Zi + Ci
        r = Sqr(Zr * Zr + Zi * Zi)
        Count = Count + 1
    Loop
    Julia = Count
End Function

---

Good luck!