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 SubCode:
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 FunctionJuliaMultithread.zip