dcsimg
Results 1 to 1 of 1

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

  1. #1

    Thread Starter
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,370

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



    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!
    Attached Files Attached Files
    Last edited by The trick; Nov 26th, 2017 at 07:39 AM.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width