Fractalis v5.0.2.*Table des procédures 1 - _modConst.vb 2 - AssemblyInfo.vb 3 - clsVideo.vb 3.1 - Public Function bAjouterImage 3.2 - Public Function bInitialiser 3.3 - Public Function bTerminer 4 - modAudioStream.vb 4.1 - Private Function GetStreamInfo 4.2 - Public Function GetFormat 4.3 - Public Function GetStreamData 4.4 - Public Function GetStreamInfo 4.5 - Public Overrides Sub ExportStream 4.6 - Public ReadOnly Property CountBitsPerSample 4.7 - Public ReadOnly Property CountChannels 4.8 - Public ReadOnly Property CountSamplesPerSecond 4.9 - Public Sub New 5 - modAVI.vb 5.1 - Public Function ToStruct 5.2 - Public Shared Function AVIFileCreateStream 5.3 - Public Shared Function AVIFileGetStream 5.4 - Public Shared Function AVIFileInfo_ 5.5 - Public Shared Function AVIFileOpen 5.6 - Public Shared Function AVIFileRelease 5.7 - Public Shared Function AVIMakeCompressedStream 5.8 - Public Shared Function AVIMakeFileFromStreams 5.9 - Public Shared Function AVISaveOptions 5.10 - Public Shared Function AVISaveOptionsFree 5.11 - Public Shared Function AVISaveV 5.12 - Public Shared Function AVIStreamGetFrame 5.13 - Public Shared Function AVIStreamGetFrameClose 5.14 - Public Shared Function AVIStreamGetFrameOpen 5.15 - Public Shared Function AVIStreamInfo_ 5.16 - Public Shared Function AVIStreamLength 5.17 - Public Shared Function AVIStreamRead 5.18 - Public Shared Function AVIStreamReadFormat 5.19 - Public Shared Function AVIStreamReadFormat 5.20 - Public Shared Function AVIStreamReadFormat 5.21 - Public Shared Function AVIStreamRelease 5.22 - Public Shared Function AVIStreamSetFormat 5.23 - Public Shared Function AVIStreamSetFormat 5.24 - Public Shared Function AVIStreamStart 5.25 - Public Shared Function AVIStreamWrite 5.26 - Public Shared Function CreateEditableStream 5.27 - Public Shared Function EditStreamCopy 5.28 - Public Shared Function EditStreamCut 5.29 - Public Shared Function EditStreamPaste 5.30 - Public Shared Function EditStreamSetInfo 5.31 - Public Shared Function mmioFOURCC 5.32 - Public Shared Function mmioStringToFOURCC 5.33 - Public Shared Sub AVIFileExit 5.34 - Public Shared Sub AVIFileInit 6 - modAVIMngr.vb 6.1 - Private Function InsertSilence 6.2 - Private Sub New 6.3 - Public Function AddVideoStream 6.4 - Public Function AddVideoStream 6.5 - Public Function AddVideoStream 6.6 - Public Function CopyTo 6.7 - Public Function GetOpenStream 6.8 - Public Function GetVideoStream 6.9 - Public Function GetWaveStream 6.10 - Public Shared Sub MakeFileFromStream 6.11 - Public Sub AddAudioStream 6.12 - Public Sub AddAudioStream 6.13 - Public Sub AddAudioStream 6.14 - Public Sub Close 6.15 - Public Sub New 7 - modAVIStream.vb 7.1 - Friend Overridable ReadOnly Property StreamPointer 7.2 - Friend ReadOnly Property FilePointer 7.3 - Friend ReadOnly Property WriteCompressed 7.4 - Public MustOverride Sub ExportStream 7.5 - Public Overridable Sub Close 8 - modVideoStream.vb 8.1 - Friend Sub New 8.2 - Private Function ConvertBitCountToPixelFormat 8.3 - Private Function ConvertPixelFormatToBitCount 8.4 - Private Function GetStreamInfo 8.5 - Private Sub CopyPalette 8.6 - Private Sub CopyPalette 8.7 - Private Sub CreateCompressedStream 8.8 - Private Sub CreateCompressedStream 8.9 - Private Sub CreateStream 8.10 - Private Sub CreateStream 8.11 - Private Sub CreateStreamWithoutFormat 8.12 - Private Sub GetRateAndScale 8.13 - Private Sub Initialize 8.14 - Private Sub SetFormat 8.15 - Public Function DecompressToNewFile 8.16 - Public Function GetBitmap 8.17 - Public Overrides Sub ExportStream 8.18 - Public ReadOnly Property CompressOptions 8.19 - Public ReadOnly Property CountBitsPerPixel 8.20 - Public ReadOnly Property CountFrames 8.21 - Public ReadOnly Property FirstFrame 8.22 - Public ReadOnly Property FrameRate 8.23 - Public ReadOnly Property FrameSize 8.24 - Public ReadOnly Property Height 8.25 - Public ReadOnly Property Palette 8.26 - Public ReadOnly Property StreamInfo 8.27 - Public ReadOnly Property Width 8.28 - Public Sub AddFrame 8.29 - Public Sub ExportBitmap 8.30 - Public Sub GetFrameClose 8.31 - Public Sub GetFrameOpen 8.32 - Public Sub New 8.33 - Public Sub New 8.34 - Public Sub New 8.35 - Public Sub New 9 - clsFract.vb 9.1 - Private Function iCompterIterations_Decimal% 9.2 - Private Function iTrouverNivIter% 9.3 - Private Sub AjouterNivIter 9.4 - Private Sub InitCoordFract 9.5 - Private Sub InitNivIter 9.6 - Protected Function bQuitter 9.7 - Protected Function iCalculerCouleur% 9.8 - Protected Function iCompterIterations% 9.9 - Protected Function InterpolateColors% 9.10 - Protected Overridable Sub InitialiserTracerFract 9.11 - Protected Overridable Sub TracerFract 9.12 - Protected Overridable Sub TracerFractProgressif 9.13 - Protected Sub InitCoordFract 9.14 - Protected Sub InitTracerFractDepart 9.15 - Public Function aptLirePoint 9.16 - Public Function CouleurPalette 9.17 - Public Function rLireAngleZoomJulia 9.18 - Public Function rLirePointJuliaX 9.19 - Public Function rLirePointJuliaY 9.20 - Public Overridable Sub InitConfig 9.21 - Public Overridable Sub InitPalette 9.22 - Public Overridable Sub TracerFractDepart 9.23 - Public Property bEffacerImg 9.24 - Public Property bJulia 9.25 - Public Property bModeDetailIterations 9.26 - Public Property bModeTranslation 9.27 - Public Property bQuitterTrace 9.28 - Public Property iDegre% 9.29 - Public Property iNbIterationsMaxDepart% 9.30 - Public Property ptfJulia 9.31 - Public Property szTailleEcran 9.32 - Public Property typeFrac 9.33 - Public ReadOnly Property iNbIterationsMax% 9.34 - Public ReadOnly Property iNbIterationsMin% 9.35 - Public ReadOnly Property rAmplitX 9.36 - Public ReadOnly Property rAmplitY 9.37 - Public ReadOnly Property rCentreX 9.38 - Public ReadOnly Property rCentreY 9.39 - Public Sub AjouterPointDetailIterations 9.40 - Public Sub CalculerNbCouleurs 9.41 - Public Sub DefinirCible 9.42 - Public Sub Deplacer 9.43 - Public Sub DeplacerPtJulia 9.44 - Public Sub FinTrace 9.45 - Public Sub FixerAnglePtJulia 9.46 - Public Sub FixerAngleZoomPtJulia 9.47 - Public Sub Initialiser 9.48 - Public Sub InitialiserIterations 9.49 - Public Sub InitialiserPrmFract 9.50 - Public Sub InitPaletteCalc 9.51 - Public Sub InitPtJulia 9.52 - Public Sub New 9.53 - Public Sub RespecterRatioZoneAbs 9.54 - Public Sub SelectionnerPoint 9.55 - Public Sub TournerPtJulia 9.56 - Public Sub ViserPoint 9.57 - Public Sub Zoomer 9.58 - Public Sub ZoomerFacteur 9.59 - Public Sub ZoomerZonePixels 9.60 - Public WriteOnly Property Gr 10 - clsFractQuadTreeR.vb 10.1 - Private Function bApprofondir 10.2 - Private Function bModeRemplissage 10.3 - Private Function bTracerQT 10.4 - Private Shadows Sub TracerFract 10.5 - Private Sub CalculerPasSuivant 10.6 - Private Sub TracerFractQuadTree 10.7 - Public Overrides Sub TracerFractDepart 11 - clsFractRapide.vb 11.1 - Private Sub InitPalette0 11.2 - Protected Overrides Sub TracerFract 11.3 - Public Overrides Sub InitConfig 11.4 - Public Overrides Sub InitPalette 11.5 - Sub PartialRender_Decimal 11.6 - Sub PartialRender_Double 12 - clsFractRemplissage.vb 12.1 - Protected Overridable Function bRemplissage 12.2 - Protected Overrides Sub InitialiserTracerFract 12.3 - Protected Overrides Sub TracerFract 13 - clsPile.vb 13.1 - Public Function bEmpiler 13.2 - Public Function bEmpiler 13.3 - Public Function bMajBmp 13.4 - Public Function bMajBmp 13.5 - Public Function bParcourirPile 13.6 - Public Function bParcourirPile 13.7 - Public Function ptDepilerPtPile 13.8 - Public Function ptDepilerPtPile 13.9 - Public ReadOnly Property bPileVide 13.10 - Public ReadOnly Property bPileVide 13.11 - Public Sub Initialiser 13.12 - Public Sub Initialiser 13.13 - Public Sub New 14 - frmConfig.vb 14.1 - Private Function bConvTxtToSng 14.2 - Private Sub Activation 14.3 - Private Sub chkAlgoRapide_CheckedChanged 14.4 - Private Sub chkDecimal_CheckedChanged 14.5 - Private Sub chkFrontiereUnie_CheckedChanged 14.6 - Private Sub chkLisser_CheckedChanged 14.7 - Private Sub chkMire_CheckChanged 14.8 - Private Sub chkModeDetailIterations_CheckedChanged 14.9 - Private Sub chkModeTranslation_CheckedChanged 14.10 - Private Sub chkPaletteAleatoire_CheckedChanged 14.11 - Private Sub chkPaletteSysteme_CheckedChanged 14.12 - Private Sub cmdAppliquer_Click 14.13 - Private Sub cmdPause_Click 14.14 - Private Sub cmdStop_Click 14.15 - Private Sub cmdZoomInit_Click 14.16 - Private Sub cmdZoomMoins_Click 14.17 - Private Sub FrmConfig_Closing 14.18 - Private Sub GestionTypeFract 14.19 - Private Sub MajTxtJulia 14.20 - Private Sub nudDegre_ValueChanged 14.21 - Private Sub nudNbCouleurs_ValueChanged 14.22 - Private Sub nudNbCyclesDegrade_ValueChanged 14.23 - Private Sub nudPremCouleur_ValueChanged 14.24 - Private Sub pbPrmJulia_MouseDown 14.25 - Private Sub pbxJulia_Paint 14.26 - Private Sub pbxVerif_paint 14.27 - Private Sub rbJulia_CheckedChanged 14.28 - Private Sub rbMandelbrot_CheckedChanged 14.29 - Private Sub rbMandelbrotEtJulia_CheckedChanged 14.30 - Private Sub txtJuliaX_TextChanged 14.31 - Private Sub txtJuliaY_TextChanged 14.32 - Private Sub VerifierPalette 14.33 - Private SubInitializeComponent 14.34 - Protected Overloads Overrides Sub Dispose 14.35 - Public Property bAlgoRapide 14.36 - Public Property bDecimal 14.37 - Public Property bEffacerImg 14.38 - Public Property bFrontiereUnie 14.39 - Public Property bJulia 14.40 - Public Property bLisser 14.41 - Public Property bMire 14.42 - Public Property bModeTranslation 14.43 - Public Property bPaletteAleatoire 14.44 - Public Property bPaletteModifiee 14.45 - Public Property bPaletteSysteme 14.46 - Public Property iDegre% 14.47 - Public Property iNbCouleurs% 14.48 - Public Property iNbCyclesDegrade% 14.49 - Public Property iNbIterationsMax% 14.50 - Public Property iPremCouleur% 14.51 - Public Property ptfJulia 14.52 - Public Property typeFrac 14.53 - Public ReadOnly Property bModeDetailIterations 14.54 - Public Sub New 14.55 - Public WriteOnly Property iAvancement% 14.56 - Public WriteOnly Property sCoordZoom$ 15 - frmFract.vb 15.1 - Private Function bIconisation 15.2 - Private Function rectNormaliserRectangle 15.3 - Private Function rectRespecterRatioZonePixels 15.4 - Private Function rectTracerSelection 15.5 - Private Sub AfficherPalette 15.6 - Private Sub DimensionnerFenetre 15.7 - Private Sub DisplayKnownColors 15.8 - Private Sub EvZoomMoins 15.9 - Private Sub EvZoomPlus 15.10 - Private Sub frmFractalis_Activated 15.11 - Private Sub frmFractalis_Closing 15.12 - Private Sub frmFractalis_FormClosed 15.13 - Private Sub frmFractalis_FormClosing 15.14 - Private Sub frmFractalis_KeyDown 15.15 - Private Sub frmFractalis_KeyPress 15.16 - Private Sub frmFractalis_Load 15.17 - Private Sub frmFractalis_MouseDown 15.18 - Private Sub frmFractalis_MouseMove 15.19 - Private Sub frmFractalis_MouseUp 15.20 - Private Sub frmFractalis_Paint 15.21 - Private Sub frmFractalis_Resize 15.22 - Private Sub InitCible 15.23 - Private Sub InitFract 15.24 - Private Sub InitialiserGraphique 15.25 - Private Sub m_clsFract_EvDetailIterations 15.26 - Private Sub m_clsFract_EvFinTrace 15.27 - Private Sub m_clsFract_EvMajAvancement 15.28 - Private Sub m_clsFract_EvMajBmp 15.29 - Private Sub m_frmConfig_EvAppliquer 15.30 - Private Sub m_frmConfig_EvDetailIterations 15.31 - Private Sub m_frmConfig_EvModeTranslation 15.32 - Private Sub m_frmConfig_EvPause 15.33 - Private Sub m_frmConfig_EvStop 15.34 - Private Sub m_frmConfig_EvZoomInit 15.35 - Private Sub m_frmConfig_EvZoomMoins 15.36 - Private Sub MajCoordZoomFrmConfig 15.37 - Private Sub MajEcranBmpCache 15.38 - Private Sub MajJuliaFrmConfig 15.39 - Private Sub RetracerPaint 15.40 - Private Sub TimerResize_Tick 15.41 - Private Sub TimerVideo_Tick 15.42 - Private SubInitializeComponent 15.43 - Protected Overloads Overrides Sub Dispose 15.44 - Public Function bTraceEnCours 15.45 - Public Sub LireConfig 15.46 - Public Sub New 15.47 - Public Sub PauseReprendreTrace 15.48 - Public Sub Retracer 15.49 - Public Sub StopTrace 16 - modUtil.vb 16.1 - Public Function bFichierAccessible 16.2 - Public Function bFichierExiste 16.3 - Public Function bSupprimerFichier 16.4 - Public Function iFix% 16.5 - Public Function iRandomiser% 16.6 - Public Function Is64BitProcess 16.7 - Public Sub AfficherMsgErreur2 16.8 - Public Sub CopierPressePapier 16.9 - Public Sub InitRnd 16.10 - Public Sub LibererRessourceDotNet 16.11 - Public Sub TraiterMsgSysteme_DoEvents _modConst.vb Module Constantes Public Const sTitreMsg$ = "Fractalis" Public Const sDateVersionAppli$ = "21/08/2024" #If DEBUG Then ' Pas de mode Release en DotNet2 : tjrs Debug Public Const bDebug As Boolean = True Public Const bDebugBugQuad As Boolean = False Public Const bDebugQuadGr As Boolean = False Public Const bDebugQuadGr2 As Boolean = False ' Si on met True, ne remplit pas le tour du cadre, seulement graine au coin HG Public Const bDebugRemp As Boolean = False Public Const bRelease As Boolean = False #Else Public Const bDebug As Boolean = False Public Const bDebugBugQuad As Boolean = False ' False Public Const bDebugQuadGr As Boolean = False ' False Public Const bDebugQuadGr2 As Boolean = False ' False Public Const bDebugRemp As Boolean = False ' False Public Const bRelease As Boolean = True #End If Public Const bAfficherPixelsFrontiereModeRemplissage As Boolean = True Public ReadOnly couleurFondCyan As Color = Color.Cyan Public Const iNbCouleursPalette% = 1024 ' 768 + 256 Public Const kcCouleurPixelNonExamine As KnownColor = KnownColor.White Public Const kcCouleurPixelFrontiere As KnownColor = KnownColor.LightGreen ' La fonction Beep() standard de .NET est totalement inaudible, ' celle-ci marche, mais elle n'est pas .NET : Public Declare Function Beep% Lib "kernel32" (dwFreq%, dwDuration%) End Module Public Structure TPrmPalette ' Paramètres de palette Dim bAfficherPalette As Boolean Dim bPaletteSysteme As Boolean Dim iPremCouleur% Dim iNbCouleurs% Dim iNbCyclesDegrade% Dim bPaletteAleatoire As Boolean ' Interpoler les couleurs de la palette d'une itération à l'autre, ' sur la base de la progression des 3 composantes RVB des 2 couleurs de la palette de dégradé ' avec un facteur dépendant de la vitesse de sortie du cercle unitaire (cf. algo. fractal) 'Dim bInterpoler As Boolean = Not m_prmPalette.bFrontiereUnie Dim bFrontiereUnie As Boolean Dim bLisser As Boolean End Structure Public Structure TCoordFract ' Structure pour les coordonnées fractales ' Coordonnées absolues dans l'ensemble de Mandelbrot ou Julia ' Un rectangle serait bien, mais il n'y a pas de constructeur ' en Decimal, seulement en Single : RectangleF ' (on a besoin de Decimal pour zoomer à fond) Dim rCoordAbsXMin, rCoordAbsXMax As Decimal Dim rCoordAbsYMin, rCoordAbsYMax As Decimal Dim rXAbs, rYAbs As Decimal Dim iPaveMaxX%, iPaveMaxY% ' Indices max. des pavés droite et bas Dim iMargeX%, iMargeY% Dim rLargPaveAbs As Decimal Dim rHautPaveAbs As Decimal Dim rZoomCible As Decimal End Structure Public Enum TFractal ' Types d'ensemble fractal Mandelbrot Julia MandelbrotEtJulia ' 01/02/2015 End Enum AssemblyInfo.vb ' Fichier AssemblyInfo.vb ' ----------------------- Imports System.Reflection <Assembly: AssemblyTitle("Fractalis")> <Assembly: AssemblyDescription( "Traceur de fractales de type Mandelbrot et Julia")> <Assembly: AssemblyCompany("")> <Assembly: AssemblyProduct("Fractalis")> <Assembly: AssemblyCopyright("Copyright © 2024")> <Assembly: AssemblyTrademark("Fractalis")> <Assembly: AssemblyVersion("5.0.2.*")> clsVideo.vb Public Class clsVideo ' Frame Rate: 30 is preferred. 23.98, 24, 25, 29.97 are also acceptable. ' https://support.google.com/youtube/answer/58134?hl=en&ref_topic=2888603 ' Pareil ! Private Const iFrameRate% = 30 Public m_bCompression As Boolean = True Public m_bVideoEnCours As Boolean = False Public m_bVideoTerminee As Boolean = False ' AVI : « Imbrication Audio Vidéo » Private m_aviManager As AviFile.AviManager Private m_aviStream As AviFile.VideoStream Public Function bInitialiser(sCheminVideo$) As Boolean If Is64BitProcess() Then m_bVideoEnCours = False m_bVideoTerminee = False Return True End If Try If Not IsNothing(m_aviManager) Then m_aviManager.Close() If IO.File.Exists(sCheminVideo) Then If Not bSupprimerFichier(sCheminVideo, bPromptErr:=True) Then Exit Function End If m_aviManager = New AviFile.AviManager(sCheminVideo, open:=False) m_aviStream = Nothing Return True Catch ex As Exception AfficherMsgErreur2(ex, "clsVideo.bInitialiser") Return False Finally m_bVideoEnCours = False m_bVideoTerminee = False End Try End Function Public Function bAjouterImage(bmp As Bitmap) As Boolean If Is64BitProcess() Then m_bVideoEnCours = True : Return True If IsNothing(m_aviStream) Then If IsNothing(m_aviManager) Then MsgBox("clsVideo.bInitialiser oublié !") Return False End If Try m_aviStream = m_aviManager.AddVideoStream(isCompressed:=m_bCompression, frameRate:=iFrameRate, firstFrame:=bmp) m_bVideoEnCours = True Return True Catch ex As Exception AfficherMsgErreur2(ex, "clsVideo.bAjouterImage", , "Cause possible : forcer 32 bits") m_bVideoEnCours = False Return False End Try Else Try m_aviStream.AddFrame(bmp) Return True Catch ex As Exception AfficherMsgErreur2(ex, "clsVideo.bAjouterImage") Return False End Try End If End Function Public Function bTerminer() As Boolean If Is64BitProcess() Then m_bVideoTerminee = True m_bVideoEnCours = False Return True End If Try If m_bVideoEnCours Then m_aviManager.Close() m_bVideoTerminee = True 'Beep(600, 20) Return True Catch ex As Exception 'Beep(400, 20) AfficherMsgErreur2(ex, "clsVideo.bTerminer") Return False Finally m_aviManager = Nothing m_aviStream = Nothing m_bVideoEnCours = False End Try End Function End Class modAudioStream.vb ' This class has been written by ' * Corinna John (Hannover, Germany) ' * cj@binary-universe.net ' * ' * You may do with this code whatever you like, ' * except selling it or claiming any rights/ownership. ' * ' * Please send me a little feedback about what you're ' * using this code for and what changes you'd like to ' * see in later versions. (And please excuse my bad english.) ' * ' * WARNING: This is experimental code. ' * Please do not expect "Release Quality". Imports System.Runtime.InteropServices Namespace AviFile Public Class AudioStream : Inherits AviStream Public ReadOnly Property CountBitsPerSample() As Integer Get Return waveFormat.wBitsPerSample End Get End Property Public ReadOnly Property CountSamplesPerSecond() As Integer Get Return waveFormat.nSamplesPerSec End Get End Property Public ReadOnly Property CountChannels() As Integer Get Return waveFormat.nChannels End Get End Property ''' <summary>the stream's format</summary> Private waveFormat As New Avi.PCMWAVEFORMAT() ''' <summary>Initialize an AudioStream for an existing stream</summary> ''' <param name="aviFile">The file that contains the stream</param> ''' <param name="aviStream">An IAVISTREAM from [aviFile]</param> Public Sub New(aviFile As Integer, aviStream As IntPtr) Me.m_aviFile = aviFile Me.m_aviStream = aviStream Dim size As Integer = Marshal.SizeOf(waveFormat) Avi.AVIStreamReadFormat(aviStream, 0, waveFormat, size) Dim streamInfo As Avi.AVISTREAMINFO = GetStreamInfo(aviStream) End Sub ''' <summary>Read the stream's header information</summary> ''' <param name="aviStream">The IAVISTREAM to read from</param> ''' <returns>AVISTREAMINFO</returns> Private Function GetStreamInfo(aviStream As IntPtr) As Avi.AVISTREAMINFO Dim streamInfo As New Avi.AVISTREAMINFO() Dim result As Integer = Avi.AVIStreamInfo_(aviStream, streamInfo, Marshal.SizeOf(streamInfo)) If result <> 0 Then Throw New Exception("Exception in AVIStreamInfo: " & result.ToString()) End If Return streamInfo End Function ''' <summary>Read the stream's header information</summary> ''' <returns>AVISTREAMINFO</returns> Public Function GetStreamInfo() As Avi.AVISTREAMINFO If WriteCompressed Then Return GetStreamInfo(m_compressedStream) Else Return GetStreamInfo(m_aviStream) End If End Function ''' <summary>Read the stream's format information</summary> ''' <returns>PCMWAVEFORMAT</returns> Public Function GetFormat() As Avi.PCMWAVEFORMAT Dim format As New Avi.PCMWAVEFORMAT() Dim size As Integer = Marshal.SizeOf(format) Dim result As Integer = Avi.AVIStreamReadFormat(m_aviStream, 0, format, size) Return format End Function ''' <summary>Returns all data needed to copy the stream</summary> ''' <remarks>Do not forget to call Marshal.FreeHGlobal and release the raw data pointer</remarks> ''' <param name="streamInfo">Receives the header information</param> ''' <param name="format">Receives the format</param> ''' <param name="streamLength">Receives the length of the stream</param> ''' <returns>Pointer to the wave data</returns> Public Function GetStreamData(ByRef streamInfo As Avi.AVISTREAMINFO, ByRef format As Avi.PCMWAVEFORMAT, ByRef streamLength As Integer) As IntPtr streamInfo = GetStreamInfo() format = GetFormat() ' Length in bytes = length in samples * length of a sample streamLength = Avi.AVIStreamLength(m_aviStream.ToInt32()) * streamInfo.dwSampleSize Dim waveData As IntPtr = Marshal.AllocHGlobal(streamLength) Dim result As Integer = Avi.AVIStreamRead(m_aviStream, 0, streamLength, waveData, streamLength, 0, 0) If result <> 0 Then Throw New Exception("Exception in AVIStreamRead: " & result.ToString()) End If Return waveData End Function ''' <summary>Copy the stream into a new file</summary> ''' <param name="fileName">Name of the new file</param> Public Overrides Sub ExportStream(fileName As [String]) Dim opts As New Avi.AVICOMPRESSOPTIONS_CLASS() opts.fccType = CType(Avi.mmioStringToFOURCC("auds", 0), UInt32) opts.fccHandler = CType(Avi.mmioStringToFOURCC("CAUD", 0), UInt32) opts.dwKeyFrameEvery = 0 opts.dwQuality = 0 opts.dwFlags = 0 opts.dwBytesPerSecond = 0 opts.lpFormat = New IntPtr(0) opts.cbFormat = 0 opts.lpParms = New IntPtr(0) opts.cbParms = 0 opts.dwInterleaveEvery = 0 Avi.AVISaveV(fileName, 0, 0, 1, m_aviStream, opts) End Sub End Class End Namespace modAVI.vb Imports System.Runtime.InteropServices Namespace AviFile Public Class Avi <StructLayout(LayoutKind.Sequential, Pack:=1)> Public Structure RGBQUAD Public rgbBlue As Byte Public rgbGreen As Byte Public rgbRed As Byte Public rgbReserved As Byte End Structure Public Shared RGBQUAD_SIZE As Integer = 4 Public Shared PALETTE_SIZE As Integer = 4 * 256 ' RGBQUAD * 256 colours Public Shared ReadOnly streamtypeVIDEO_VIDS As Integer = mmioFOURCC("v"c, "i"c, "d"c, "s"c) Public Shared ReadOnly streamtypeAUDIO As Integer = mmioFOURCC("a"c, "u"c, "d"c, "s"c) Public Shared ReadOnly streamtypeMIDI As Integer = mmioFOURCC("m"c, "i"c, "d"c, "s"c) Public Shared ReadOnly streamtypeTEXT As Integer = mmioFOURCC("t"c, "x"c, "t"c, "s"c) Public Const OF_SHARE_DENY_WRITE As Integer = 32 Public Const OF_WRITE As Integer = 1 Public Const OF_READWRITE As Integer = 2 Public Const OF_CREATE As Integer = 4096 Public Const BMP_MAGIC_COOKIE As Integer = 19778 ' ascii string "BM" Public Const AVICOMPRESSF_INTERLEAVE As Integer = &H1 ' interleave Public Const AVICOMPRESSF_DATARATE As Integer = &H2 ' use a data rate Public Const AVICOMPRESSF_KEYFRAMES As Integer = &H4 ' use keyframes Public Const AVICOMPRESSF_VALID As Integer = &H8 ' has valid data Public Const AVIIF_KEYFRAME As Integer = &H10 Public Const ICMF_CHOOSE_KEYFRAME As UInt32 = &H1 ' show KeyFrame Every box Public Const ICMF_CHOOSE_DATARATE As UInt32 = &H2 ' show DataRate box Public Const ICMF_CHOOSE_PREVIEW As UInt32 = &H4 ' allow expanded preview dialog ' macro mmioFOURCC Public Shared Function mmioFOURCC(ch0 As Char, ch1 As Char, ch2 As Char, ch3 As Char) As Int32 Dim i0% = CType(CByte(AscW(ch0)), Int32) Dim i1% = CType(CByte(AscW(ch1)), Int32) << 8 Dim i2% = CType(CByte(AscW(ch2)), Int32) << 16 Dim i3% = CType(CByte(AscW(ch3)), Int32) << 24 Dim iRet% = ( CType(CByte(AscW(ch0)), Int32) Or (CType(CByte(AscW(ch1)), Int32) << 8) Or (CType(CByte(AscW(ch2)), Int32) << 16) Or (CType(CByte(AscW(ch3)), Int32) << 24)) 'Debug.WriteLine("mmioFOURCC : " & ch0 & ch1 & ch2 & ch3 & " -> " & iRet) Return iRet End Function #Region "structure declarations" <StructLayout(LayoutKind.Sequential, Pack:=1)> Public Structure RECT Public left As UInt32 Public top As UInt32 Public right As UInt32 Public bottom As UInt32 End Structure <StructLayout(LayoutKind.Sequential, Pack:=1)> Public Structure BITMAPINFOHEADER Public biSize As Int32 Public biWidth As Int32 Public biHeight As Int32 Public biPlanes As Int16 Public biBitCount As Int16 Public biCompression As Int32 Public biSizeImage As Int32 Public biXPelsPerMeter As Int32 Public biYPelsPerMeter As Int32 Public biClrUsed As Int32 Public biClrImportant As Int32 End Structure <StructLayout(LayoutKind.Sequential, Pack:=1)> Public Structure BITMAPINFO Public bmiHeader As BITMAPINFOHEADER <MarshalAs(UnmanagedType.ByValArray, SizeConst:=256)> Public bmiColors As RGBQUAD() End Structure <StructLayout(LayoutKind.Sequential)> Public Structure PCMWAVEFORMAT Public wFormatTag As Short Public nChannels As Short Public nSamplesPerSec As Integer Public nAvgBytesPerSec As Integer Public nBlockAlign As Short Public wBitsPerSample As Short Public cbSize As Short End Structure <StructLayout(LayoutKind.Sequential, Pack:=1)> Public Structure AVISTREAMINFO Public fccType As Int32 Public fccHandler As Int32 Public dwFlags As Int32 Public dwCaps As Int32 Public wPriority As Int16 Public wLanguage As Int16 Public dwScale As Int32 Public dwRate As Int32 Public dwStart As Int32 Public dwLength As Int32 Public dwInitialFrames As Int32 Public dwSuggestedBufferSize As Int32 Public dwQuality As Int32 Public dwSampleSize As Int32 Public rcFrame As RECT Public dwEditCount As Int32 Public dwFormatChangeCount As Int32 <MarshalAs(UnmanagedType.ByValArray, SizeConst:=64)> Public szName As UInt16() End Structure <StructLayout(LayoutKind.Sequential, Pack:=1)> Public Structure BITMAPFILEHEADER Public bfType As Int16 ' "magic cookie" - must be "BM" Public bfSize As Int32 Public bfReserved1 As Int16 Public bfReserved2 As Int16 Public bfOffBits As Int32 End Structure <StructLayout(LayoutKind.Sequential, Pack:=1)> Public Structure AVIFILEINFO Public dwMaxBytesPerSecond As Int32 Public dwFlags As Int32 Public dwCaps As Int32 Public dwStreams As Int32 Public dwSuggestedBufferSize As Int32 Public dwWidth As Int32 Public dwHeight As Int32 Public dwScale As Int32 Public dwRate As Int32 Public dwLength As Int32 Public dwEditCount As Int32 <MarshalAs(UnmanagedType.ByValArray, SizeConst:=64)> Public szFileType As Char() End Structure ' https://msdn.microsoft.com/en-us/library/windows/desktop/dd756791%28v=vs.85%29.aspx <StructLayout(LayoutKind.Sequential, Pack:=1)> Public Structure AVICOMPRESSOPTIONS '#define streamtypeVIDEO FCC('vids') ' Indicates a video stream '#define streamtypeAUDIO FCC('auds') ' Indicates an audio stream '#define streamtypeMIDI FCC('mids') ' Indicates a MIDI stream '#define streamtypeTEXT FCC('txts') ' Indicates a text stream Public fccType As UInt32 Public fccHandler As UInt32 Public dwKeyFrameEvery As UInt32 ' only used with AVICOMRPESSF_KEYFRAMES Public dwQuality As UInt32 Public dwBytesPerSecond As UInt32 ' only used with AVICOMPRESSF_DATARATE Public dwFlags As UInt32 Public lpFormat As IntPtr Public cbFormat As UInt32 Public lpParms As IntPtr Public cbParms As UInt32 Public dwInterleaveEvery As UInt32 End Structure ''' <summary>AviSaveV needs a pointer to a pointer to an AVICOMPRESSOPTIONS structure</summary> <StructLayout(LayoutKind.Sequential, Pack:=1)> Public Class AVICOMPRESSOPTIONS_CLASS Public fccType As UInt32 Public fccHandler As UInt32 Public dwKeyFrameEvery As UInt32 ' only used with AVICOMRPESSF_KEYFRAMES Public dwQuality As UInt32 Public dwBytesPerSecond As UInt32 ' only used with AVICOMPRESSF_DATARATE Public dwFlags As UInt32 Public lpFormat As IntPtr Public cbFormat As UInt32 Public lpParms As IntPtr Public cbParms As UInt32 Public dwInterleaveEvery As UInt32 Public Function ToStruct() As AVICOMPRESSOPTIONS Dim returnVar As New AVICOMPRESSOPTIONS() returnVar.fccType = Me.fccType returnVar.fccHandler = Me.fccHandler returnVar.dwKeyFrameEvery = Me.dwKeyFrameEvery returnVar.dwQuality = Me.dwQuality returnVar.dwBytesPerSecond = Me.dwBytesPerSecond returnVar.dwFlags = Me.dwFlags returnVar.lpFormat = Me.lpFormat returnVar.cbFormat = Me.cbFormat returnVar.lpParms = Me.lpParms returnVar.cbParms = Me.cbParms returnVar.dwInterleaveEvery = Me.dwInterleaveEvery Return returnVar End Function End Class #End Region #Region "method declarations" ' Initialize the AVI library <DllImport("avifil32.dll")> Public Shared Sub AVIFileInit() End Sub ' Open an AVI file <DllImport("avifil32.dll", PreserveSig:=True)> Public Shared Function AVIFileOpen(ByRef ppfile As Integer, szFile As [String], uMode As Integer, pclsidHandler As Integer) As Integer End Function ' Get a stream from an open AVI file <DllImport("avifil32.dll")> Public Shared Function AVIFileGetStream(pfile As Integer, ByRef ppavi As IntPtr, fccType As Integer, lParam As Integer) As Integer End Function ' Get the start position of a stream <DllImport("avifil32.dll", PreserveSig:=True)> Public Shared Function AVIStreamStart(pavi As Integer) As Integer End Function ' Get the length of a stream in frames <DllImport("avifil32.dll", PreserveSig:=True)> Public Shared Function AVIStreamLength(pavi As Integer) As Integer End Function ' Get information about an open stream <DllImport("avifil32.dll")> Public Shared Function AVIStreamInfo_(pAVIStream As IntPtr, ByRef psi As AVISTREAMINFO, lSize As Integer) As Integer End Function ' Get a pointer to a GETFRAME object (returns 0 on error) <DllImport("avifil32.dll")> Public Shared Function AVIStreamGetFrameOpen(pAVIStream As IntPtr, ByRef bih As BITMAPINFOHEADER) As Integer End Function ' Get a pointer to a packed DIB (returns 0 on error) <DllImport("avifil32.dll")> Public Shared Function AVIStreamGetFrame(pGetFrameObj As Integer, lPos As Integer) As Integer End Function ' Create a new stream in an open AVI file <DllImport("avifil32.dll")> Public Shared Function AVIFileCreateStream(pfile As Integer, ByRef ppavi As IntPtr, ByRef ptr_streaminfo As AVISTREAMINFO) As Integer End Function ' Create an editable stream <DllImport("avifil32.dll")> Public Shared Function CreateEditableStream(ByRef ppsEditable As IntPtr, psSource As IntPtr) As Integer End Function ' Cut samples from an editable stream <DllImport("avifil32.dll")> Public Shared Function EditStreamCut(pStream As IntPtr, ByRef plStart As Int32, ByRef plLength As Int32, ByRef ppResult As IntPtr) As Integer End Function ' Copy a part of an editable stream <DllImport("avifil32.dll")> Public Shared Function EditStreamCopy(pStream As IntPtr, ByRef plStart As Int32, ByRef plLength As Int32, ByRef ppResult As IntPtr) As Integer End Function ' Paste an editable stream into another editable stream <DllImport("avifil32.dll")> Public Shared Function EditStreamPaste(pStream__1 As IntPtr, ByRef plPos As Int32, ByRef plLength As Int32, pstream__2 As IntPtr, lStart As Int32, lLength As Int32) As Integer End Function ' Change a stream's header values <DllImport("avifil32.dll")> Public Shared Function EditStreamSetInfo(pStream As IntPtr, ByRef lpInfo As AVISTREAMINFO, cbInfo As Int32) As Integer End Function <DllImport("avifil32.dll")> Public Shared Function AVIMakeFileFromStreams(ByRef ppfile As IntPtr, nStreams As Integer, ByRef papStreams As IntPtr) As Integer End Function ' Set the format for a new stream <DllImport("avifil32.dll")> Public Shared Function AVIStreamSetFormat(aviStream As IntPtr, lPos As Int32, ByRef lpFormat As BITMAPINFO, cbFormat As Int32) As Integer End Function ' Set the format for a new stream <DllImport("avifil32.dll")> Public Shared Function AVIStreamSetFormat(aviStream As IntPtr, lPos As Int32, ByRef lpFormat As PCMWAVEFORMAT, cbFormat As Int32) As Integer End Function ' Read the format for a stream <DllImport("avifil32.dll")> Public Shared Function AVIStreamReadFormat(aviStream As IntPtr, lPos As Int32, ByRef lpFormat As BITMAPINFO, ByRef cbFormat As Int32) As Integer End Function ' Read the size of the format for a stream <DllImport("avifil32.dll")> Public Shared Function AVIStreamReadFormat(aviStream As IntPtr, lPos As Int32, empty As Integer, ByRef cbFormat As Int32) As Integer End Function ' Read the format for a stream <DllImport("avifil32.dll")> Public Shared Function AVIStreamReadFormat(aviStream As IntPtr, lPos As Int32, ByRef lpFormat As PCMWAVEFORMAT, ByRef cbFormat As Int32) As Integer End Function ' Write a sample to a stream <DllImport("avifil32.dll")> Public Shared Function AVIStreamWrite(aviStream As IntPtr, lStart As Int32, lSamples As Int32, lpBuffer As IntPtr, cbBuffer As Int32, dwFlags As Int32, dummy1 As Int32, dummy2 As Int32) As Integer End Function ' Release the GETFRAME object <DllImport("avifil32.dll")> Public Shared Function AVIStreamGetFrameClose(pGetFrameObj As Integer) As Integer End Function ' Release an open AVI stream <DllImport("avifil32.dll")> Public Shared Function AVIStreamRelease(aviStream As IntPtr) As Integer End Function ' Release an open AVI file <DllImport("avifil32.dll")> Public Shared Function AVIFileRelease(pfile As Integer) As Integer End Function ' Close the AVI library <DllImport("avifil32.dll")> Public Shared Sub AVIFileExit() End Sub <DllImport("avifil32.dll")> Public Shared Function AVIMakeCompressedStream(ByRef ppsCompressed As IntPtr, aviStream As IntPtr, ByRef ao As AVICOMPRESSOPTIONS, dummy As Integer) As Integer End Function <DllImport("avifil32.dll")> Public Shared Function AVISaveOptions(hwnd As IntPtr, uiFlags As UInt32, nStreams As Int32, ByRef ppavi As IntPtr, ByRef plpOptions As AVICOMPRESSOPTIONS_CLASS) As Boolean End Function <DllImport("avifil32.dll")> Public Shared Function AVISaveOptionsFree(nStreams As Integer, ByRef plpOptions As AVICOMPRESSOPTIONS_CLASS) As Long End Function <DllImport("avifil32.dll")> Public Shared Function AVIFileInfo_(pfile As Integer, ByRef pfi As AVIFILEINFO, lSize As Integer) As Integer End Function <DllImport("winmm.dll", EntryPoint:="mmioStringToFOURCCA")> Public Shared Function mmioStringToFOURCC(sz As [String], uFlags As Integer) As Integer End Function <DllImport("avifil32.dll")> Public Shared Function AVIStreamRead(pavi As IntPtr, lStart As Int32, lSamples As Int32, lpBuffer As IntPtr, cbBuffer As Int32, plBytes As Int32, plSamples As Int32) As Integer End Function <DllImport("avifil32.dll")> Public Shared Function AVISaveV(szFile As [String], empty As Int16, lpfnCallback As Int16, nStreams As Int16, ByRef ppavi As IntPtr, ByRef plpOptions As AVICOMPRESSOPTIONS_CLASS) As Integer End Function #End Region End Class End Namespace modAVIMngr.vb ' This class has been written by ' * Corinna John (Hannover, Germany) ' * cj@binary-universe.net ' * ' * You may do with this code whatever you like, ' * except selling it or claiming any rights/ownership. ' * ' * Please send me a little feedback about what you're ' * using this code for and what changes you'd like to ' * see in later versions. (And please excuse my bad english.) ' * ' * WARNING: This is experimental code. ' * Please do not expect "Release Quality". Imports System.Drawing.Imaging Imports System.Runtime.InteropServices Namespace AviFile Public Class AviManager Private aviFile As Integer = 0 Private streams As New ArrayList() ''' <summary>Open or create an AVI file</summary> ''' <param name="fileName">Name of the AVI file</param> ''' <param name="open">true: Open the file; false: Create or overwrite the file</param> Public Sub New(fileName As [String], open As Boolean) Avi.AVIFileInit() Dim result As Integer If open Then ' Open existing file result = Avi.AVIFileOpen(aviFile, fileName, Avi.OF_READWRITE, 0) Else ' Create empty file result = Avi.AVIFileOpen(aviFile, fileName, Avi.OF_WRITE Or Avi.OF_CREATE, 0) End If If result <> 0 Then Throw New Exception("Exception in AVIFileOpen: " & result.ToString()) End If End Sub Private Sub New(aviFile As Integer) Me.aviFile = aviFile End Sub ''' <summary>Get the first video stream - usually there is only one video stream</summary> ''' <returns>VideoStream object for the stream</returns> Public Function GetVideoStream() As VideoStream Dim aviStream As IntPtr Dim result As Integer = Avi.AVIFileGetStream(aviFile, aviStream, Avi.streamtypeVIDEO_VIDS, 0) If result <> 0 Then Throw New Exception("Exception in AVIFileGetStream: " & result.ToString()) End If Dim stream As New VideoStream(aviFile, aviStream) streams.Add(stream) Return stream End Function ''' <summary>Getthe first wave audio stream</summary> ''' <returns>AudioStream object for the stream</returns> Public Function GetWaveStream() As AudioStream Dim aviStream As IntPtr Dim result As Integer = Avi.AVIFileGetStream(aviFile, aviStream, Avi.streamtypeAUDIO, 0) If result <> 0 Then Throw New Exception("Exception in AVIFileGetStream: " & result.ToString()) End If Dim stream As New AudioStream(aviFile, aviStream) streams.Add(stream) Return stream End Function ''' <summary>Get a stream from the internal list of opened streams</summary> ''' <param name="index">Index of the stream. The streams are not sorted, the first stream is the one that was opened first.</param> ''' <returns>VideoStream at position [index]</returns> ''' <remarks> ''' Use this method after DecompressToNewFile, ''' to get the copied stream from the new AVI file ''' </remarks> ''' <example> ''' //streams cannot be edited - copy to a new file ''' AviManager newManager = aviStream.DecompressToNewFile(@"..\..\testdata\temp.avi", true); ''' //there is only one stream in the new file - get it and add a frame ''' VideoStream aviStream = newManager.GetOpenStream(0); ''' aviStream.AddFrame(bitmap); ''' </example> Public Function GetOpenStream(index As Integer) As VideoStream Return DirectCast(streams(index), VideoStream) End Function ''' <summary>Add an empty video stream to the file</summary> ''' <param name="isCompressed">true: Create a compressed stream before adding frames</param> ''' <param name="frameRate">Frames per second</param> ''' <param name="frameSize">Size of one frame in bytes</param> ''' <param name="width">Width of each image</param> ''' <param name="height">Height of each image</param> ''' <param name="format">PixelFormat of the images</param> ''' <returns>VideoStream object for the new stream</returns> Public Function AddVideoStream(isCompressed As Boolean, frameRate As Double, frameSize As Integer, width As Integer, height As Integer, format As PixelFormat) As VideoStream Dim stream As New VideoStream(aviFile, isCompressed, frameRate, frameSize, width, height, format) streams.Add(stream) Return stream End Function ''' <summary>Add an empty video stream to the file</summary> ''' <remarks>Compresses the stream without showing the codecs dialog</remarks> ''' <param name="compressOptions">Compression options</param> ''' <param name="frameRate">Frames per second</param> ''' <param name="firstFrame">Image to write into the stream as the first frame</param> ''' <returns>VideoStream object for the new stream</returns> Public Function AddVideoStream(compressOptions As Avi.AVICOMPRESSOPTIONS, frameRate As Double, firstFrame As Bitmap) As VideoStream Dim stream As New VideoStream(aviFile, compressOptions, frameRate, firstFrame) streams.Add(stream) Return stream End Function ''' <summary>Add an empty video stream to the file</summary> ''' <param name="isCompressed">true: Create a compressed stream before adding frames</param> ''' <param name="frameRate">Frames per second</param> ''' <param name="firstFrame">Image to write into the stream as the first frame</param> ''' <returns>VideoStream object for the new stream</returns> Public Function AddVideoStream(isCompressed As Boolean, frameRate As Double, firstFrame As Bitmap) As VideoStream Dim stream As New VideoStream(aviFile, isCompressed, frameRate, firstFrame) streams.Add(stream) Return stream End Function ''' <summary>Add a wave audio stream from another file to this file</summary> ''' <param name="waveFileName">Name of the wave file to add</param> ''' <param name="startAtFrameIndex">Index of the video frame at which the sound is going to start</param> Public Sub AddAudioStream(waveFileName As [String], startAtFrameIndex As Integer) Dim audioManager As New AviManager(waveFileName, True) Dim newStream As AudioStream = audioManager.GetWaveStream() AddAudioStream(newStream, startAtFrameIndex) audioManager.Close() End Sub Private Function InsertSilence(countSilentSamples As Integer, waveData As IntPtr, lengthWave As Integer, ByRef streamInfo As Avi.AVISTREAMINFO) As IntPtr ' Initialize silence Dim lengthSilence As Integer = countSilentSamples * streamInfo.dwSampleSize Dim silence As Byte() = New Byte(lengthSilence - 1) {} ' Initialize new sound Dim lengthNewStream As Integer = lengthSilence + lengthWave Dim newWaveData As IntPtr = Marshal.AllocHGlobal(lengthNewStream) ' Copy silence Marshal.Copy(silence, 0, newWaveData, lengthSilence) ' Copy sound Dim sound As Byte() = New Byte(lengthWave - 1) {} Marshal.Copy(waveData, sound, 0, lengthWave) Dim startOfSound As New IntPtr(newWaveData.ToInt32() + lengthSilence) Marshal.Copy(sound, 0, startOfSound, lengthWave) Marshal.FreeHGlobal(newWaveData) streamInfo.dwLength = lengthNewStream Return newWaveData End Function ''' <summary>Add an existing wave audio stream to the file</summary> ''' <param name="newStream">The stream to add</param> ''' <param name="startAtFrameIndex"> ''' The index of the video frame at which the sound is going to start. ''' '0' inserts the sound at the beginning of the video. ''' </param> Public Sub AddAudioStream(newStream As AudioStream, startAtFrameIndex As Integer) Dim streamInfo As New Avi.AVISTREAMINFO() Dim streamFormat As New Avi.PCMWAVEFORMAT() Dim streamLength As Integer = 0 Dim rawData As IntPtr = newStream.GetStreamData(streamInfo, streamFormat, streamLength) Dim waveData As IntPtr = rawData If startAtFrameIndex > 0 Then ' Not supported ' streamInfo.dwStart = startAtFrameIndex; Dim framesPerSecond As Double = GetVideoStream().FrameRate Dim samplesPerSecond As Double = newStream.CountSamplesPerSecond Dim startAtSecond As Double = startAtFrameIndex / framesPerSecond Dim startAtSample As Integer = CInt(Math.Truncate(samplesPerSecond * startAtSecond)) waveData = InsertSilence(startAtSample - 1, waveData, streamLength, streamInfo) End If Dim aviStream As IntPtr Dim result As Integer = Avi.AVIFileCreateStream(aviFile, aviStream, streamInfo) If result <> 0 Then Throw New Exception("Exception in AVIFileCreateStream: " & result.ToString()) End If result = Avi.AVIStreamSetFormat(aviStream, 0, streamFormat, Marshal.SizeOf(streamFormat)) If result <> 0 Then Throw New Exception("Exception in AVIStreamSetFormat: " & result.ToString()) End If result = Avi.AVIStreamWrite(aviStream, 0, streamLength, waveData, streamLength, Avi.AVIIF_KEYFRAME, 0, 0) If result <> 0 Then Throw New Exception("Exception in AVIStreamWrite: " & result.ToString()) End If result = Avi.AVIStreamRelease(aviStream) If result <> 0 Then Throw New Exception("Exception in AVIStreamRelease: " & result.ToString()) End If Marshal.FreeHGlobal(waveData) End Sub ''' <summary>Add an existing wave audio stream to the file</summary> ''' <param name="waveData">The new stream's data</param> ''' <param name="streamInfo">Header info for the new stream</param> ''' <param name="streamFormat">The new stream' format info</param> ''' <param name="streamLength">Length of the new stream</param> Public Sub AddAudioStream(waveData As IntPtr, streamInfo As Avi.AVISTREAMINFO, streamFormat As Avi.PCMWAVEFORMAT, streamLength As Integer) Dim aviStream As IntPtr Dim result As Integer = Avi.AVIFileCreateStream(aviFile, aviStream, streamInfo) If result <> 0 Then Throw New Exception("Exception in AVIFileCreateStream: " & result.ToString()) End If result = Avi.AVIStreamSetFormat(aviStream, 0, streamFormat, Marshal.SizeOf(streamFormat)) If result <> 0 Then Throw New Exception("Exception in AVIStreamSetFormat: " & result.ToString()) End If result = Avi.AVIStreamWrite(aviStream, 0, streamLength, waveData, streamLength, Avi.AVIIF_KEYFRAME, 0, 0) If result <> 0 Then Throw New Exception("Exception in AVIStreamWrite: " & result.ToString()) End If result = Avi.AVIStreamRelease(aviStream) If result <> 0 Then Throw New Exception("Exception in AVIStreamRelease: " & result.ToString()) End If End Sub ''' <summary>Copy a piece of video and wave sound int a new file</summary> ''' <param name="newFileName">File name</param> ''' <param name="startAtSecond">Start copying at second x</param> ''' <param name="stopAtSecond">Stop copying at second y</param> ''' <returns>AviManager for the new video</returns> Public Function CopyTo(newFileName As [String], startAtSecond As Single, stopAtSecond As Single) As AviManager Dim newFile As New AviManager(newFileName, False) Try ' Copy video stream Dim videoStream As VideoStream = GetVideoStream() Dim startFrameIndex As Integer = CInt(Math.Truncate(videoStream.FrameRate * startAtSecond)) Dim stopFrameIndex As Integer = CInt(Math.Truncate(videoStream.FrameRate * stopAtSecond)) videoStream.GetFrameOpen() Dim bmp As Bitmap = videoStream.GetBitmap(startFrameIndex) Dim newStream As VideoStream = newFile.AddVideoStream(False, videoStream.FrameRate, bmp) For n As Integer = startFrameIndex + 1 To stopFrameIndex bmp = videoStream.GetBitmap(n) newStream.AddFrame(bmp) Next videoStream.GetFrameClose() ' Copy audio stream Dim waveStream As AudioStream = GetWaveStream() Dim streamInfo As New Avi.AVISTREAMINFO() Dim streamFormat As New Avi.PCMWAVEFORMAT() Dim streamLength As Integer = 0 Dim ptrRawData As IntPtr = waveStream.GetStreamData(streamInfo, streamFormat, streamLength) Dim startByteIndex As Integer = CInt(Math.Truncate(startAtSecond * CSng(waveStream.CountSamplesPerSecond * streamFormat.nChannels * waveStream.CountBitsPerSample) / 8)) Dim stopByteIndex As Integer = CInt(Math.Truncate(stopAtSecond * CSng(waveStream.CountSamplesPerSecond * streamFormat.nChannels * waveStream.CountBitsPerSample) / 8)) Dim ptrWavePart As New IntPtr(ptrRawData.ToInt32() + startByteIndex) Dim rawData As Byte() = New Byte(stopByteIndex - startByteIndex - 1) {} Marshal.Copy(ptrWavePart, rawData, 0, rawData.Length) Marshal.FreeHGlobal(ptrRawData) streamInfo.dwLength = rawData.Length streamInfo.dwStart = 0 Dim unmanagedRawData As IntPtr = Marshal.AllocHGlobal(rawData.Length) Marshal.Copy(rawData, 0, unmanagedRawData, rawData.Length) newFile.AddAudioStream(unmanagedRawData, streamInfo, streamFormat, rawData.Length) Marshal.FreeHGlobal(unmanagedRawData) Catch ex As Exception newFile.Close() Throw ex End Try Return newFile End Function ''' <summary>Release all ressources</summary> Public Sub Close() For Each stream As AviStream In streams stream.Close() Next Avi.AVIFileRelease(aviFile) Avi.AVIFileExit() End Sub Public Shared Sub MakeFileFromStream(fileName As [String], stream As AviStream) Dim newFile As IntPtr = IntPtr.Zero Dim streamPointer As IntPtr = stream.StreamPointer Dim opts As New Avi.AVICOMPRESSOPTIONS_CLASS() opts.fccType = CUInt(Avi.streamtypeVIDEO_VIDS) opts.lpParms = IntPtr.Zero opts.lpFormat = IntPtr.Zero Avi.AVISaveOptions(IntPtr.Zero, Avi.ICMF_CHOOSE_KEYFRAME Or Avi.ICMF_CHOOSE_DATARATE, 1, streamPointer, opts) Avi.AVISaveOptionsFree(1, opts) Avi.AVISaveV(fileName, 0, 0, 1, streamPointer, opts) End Sub End Class End Namespace modAVIStream.vb Namespace AviFile Public MustInherit Class AviStream Protected m_aviFile As Integer Protected m_aviStream As IntPtr Protected m_compressedStream As IntPtr Protected m_writeCompressed As Boolean ''' <summary>Pointer to the unmanaged AVI file</summary> Friend ReadOnly Property FilePointer() As Integer Get Return m_aviFile End Get End Property ''' <summary>Pointer to the unmanaged AVI Stream</summary> Friend Overridable ReadOnly Property StreamPointer() As IntPtr Get Return m_aviStream End Get End Property ''' <summary>Flag: The stream is compressed/uncompressed</summary> Friend ReadOnly Property WriteCompressed() As Boolean Get Return m_writeCompressed End Get End Property ''' <summary>Close the stream</summary> Public Overridable Sub Close() If m_writeCompressed Then Avi.AVIStreamRelease(m_compressedStream) End If Avi.AVIStreamRelease(StreamPointer) End Sub ''' <summary>Export the stream into a new file</summary> ''' <param name="fileName"></param> Public MustOverride Sub ExportStream(fileName As [String]) End Class End Namespace modVideoStream.vb ' This class has been written by ' * Corinna John (Hannover, Germany) ' * cj@binary-universe.net ' * ' * You may do with this code whatever you like, ' * except selling it or claiming any rights/ownership. ' * ' * Please send me a little feedback about what you're ' * using this code for and what changes you'd like to ' * see in later versions. (And please excuse my bad english.) ' * ' * WARNING: This is experimental code. ' * Please do not expect "Release Quality". Imports System.IO Imports System.Drawing.Imaging Imports System.Runtime.InteropServices Namespace AviFile Public Class VideoStream : Inherits AviStream Public Class typeFlux Public Const sTypeAudio$ = "auds" Public Const sTypeText$ = "txts" Public Const sTypeVideo$ = "vids" Public Const sTypeMidi$ = "mids" End Class ''' <summary>handle for AVIStreamGetFrame</summary> Private getFrameObject As Integer ''' <summary>size of an imge in bytes, stride*height</summary> Private m_frameSize As Integer Public ReadOnly Property FrameSize() As Integer Get Return m_frameSize End Get End Property Protected m_frameRate As Double Public ReadOnly Property FrameRate() As Double Get Return m_frameRate End Get End Property Private m_width As Integer Public ReadOnly Property Width() As Integer Get Return m_width End Get End Property Private m_height As Integer Public ReadOnly Property Height() As Integer Get Return m_height End Get End Property Private m_countBitsPerPixel As Int16 Public ReadOnly Property CountBitsPerPixel() As Int16 Get Return m_countBitsPerPixel End Get End Property ''' <summary>count of frames in the stream</summary> Protected m_countFrames As Integer = 0 Public ReadOnly Property CountFrames() As Integer Get Return m_countFrames End Get End Property ''' <summary>Palette for indexed frames</summary> Protected m_palette As Avi.RGBQUAD() Public ReadOnly Property Palette() As Avi.RGBQUAD() Get Return m_palette End Get End Property ''' <summary>initial frame index</summary> ''' <remarks>Added by M. Covington</remarks> Protected m_firstFrame As Integer = 0 Public ReadOnly Property FirstFrame() As Integer Get Return m_firstFrame End Get End Property Private m_compressOptions As Avi.AVICOMPRESSOPTIONS Public ReadOnly Property CompressOptions() As Avi.AVICOMPRESSOPTIONS Get Return m_compressOptions End Get End Property Public ReadOnly Property StreamInfo() As Avi.AVISTREAMINFO Get Return GetStreamInfo(m_aviStream) End Get End Property ''' <summary>Initialize an empty VideoStream</summary> ''' <param name="aviFile">The file that contains the stream</param> ''' <param name="writeCompressed">true: Create a compressed stream before adding frames</param> ''' <param name="frameRate">Frames per second</param> ''' <param name="frameSize">Size of one frame in bytes</param> ''' <param name="width">Width of each image</param> ''' <param name="height">Height of each image</param> ''' <param name="format">PixelFormat of the images</param> Public Sub New(aviFile As Integer, writeCompressed As Boolean, frameRate As Double, frameSize As Integer, width As Integer, height As Integer, format As PixelFormat) Me.m_aviFile = aviFile Me.m_writeCompressed = writeCompressed Me.m_frameRate = frameRate Me.m_frameSize = frameSize Me.m_width = width Me.m_height = height Me.m_countBitsPerPixel = ConvertPixelFormatToBitCount(format) Me.m_firstFrame = 0 CreateStream() End Sub ''' <summary>Initialize a new VideoStream and add the first frame</summary> ''' <param name="aviFile">The file that contains the stream</param> ''' <param name="writeCompressed">true: create a compressed stream before adding frames</param> ''' <param name="frameRate">Frames per second</param> ''' <param name="firstFrame">Image to write into the stream as the first frame</param> Public Sub New(aviFile As Integer, writeCompressed As Boolean, frameRate As Double, firstFrame As Bitmap) Initialize(aviFile, writeCompressed, frameRate, firstFrame) CreateStream() AddFrame(firstFrame) End Sub ''' <summary>Initialize a new VideoStream and add the first frame</summary> ''' <param name="aviFile">The file that contains the stream</param> ''' <param name="compressOptions">true: create a compressed stream before adding frames</param> ''' <param name="frameRate">Frames per second</param> ''' <param name="firstFrame">Image to write into the stream as the first frame</param> Public Sub New(aviFile As Integer, compressOptions As Avi.AVICOMPRESSOPTIONS, frameRate As Double, firstFrame As Bitmap) Initialize(aviFile, True, frameRate, firstFrame) CreateStream(compressOptions) AddFrame(firstFrame) End Sub ''' <summary>Initialize a VideoStream for an existing stream</summary> ''' <param name="aviFile">The file that contains the stream</param> ''' <param name="aviStream">An IAVISTREAM from [aviFile]</param> Public Sub New(aviFile As Integer, aviStream As IntPtr) Me.m_aviFile = aviFile Me.m_aviStream = aviStream Dim streamInfo As Avi.AVISTREAMINFO = GetStreamInfo(aviStream) 'Avi.BITMAPINFOHEADER bih = new Avi.BITMAPINFOHEADER(); 'int size = Marshal.SizeOf(bih); Dim bih As New Avi.BITMAPINFO() Dim size As Integer = Marshal.SizeOf(bih.bmiHeader) Avi.AVIStreamReadFormat(aviStream, 0, bih, size) If bih.bmiHeader.biBitCount < 24 Then size = Marshal.SizeOf(bih.bmiHeader) + Avi.PALETTE_SIZE Avi.AVIStreamReadFormat(aviStream, 0, bih, size) CopyPalette(bih.bmiColors) End If Me.m_frameRate = CSng(streamInfo.dwRate) / CSng(streamInfo.dwScale) Me.m_width = CInt(streamInfo.rcFrame.right) Me.m_height = CInt(streamInfo.rcFrame.bottom) Me.m_frameSize = bih.bmiHeader.biSizeImage Me.m_countBitsPerPixel = bih.bmiHeader.biBitCount Me.m_firstFrame = Avi.AVIStreamStart(aviStream.ToInt32()) Me.m_countFrames = Avi.AVIStreamLength(aviStream.ToInt32()) End Sub ''' <summary>Copy all properties from one VideoStream to another one</summary> ''' <remarks>Used by EditableVideoStream</remarks> ''' <param name="frameSize"></param><param name="frameRate"></param> ''' <param name="width"></param><param name="height"></param> ''' <param name="countBitsPerPixel"></param> ''' <param name="countFrames"></param><param name="compressOptions"></param> Friend Sub New(frameSize As Integer, frameRate As Double, width As Integer, height As Integer, countBitsPerPixel As Int16, countFrames As Integer, compressOptions As Avi.AVICOMPRESSOPTIONS, writeCompressed As Boolean) Me.m_frameSize = frameSize Me.m_frameRate = frameRate Me.m_width = width Me.m_height = height Me.m_countBitsPerPixel = countBitsPerPixel Me.m_countFrames = countFrames Me.m_compressOptions = compressOptions Me.m_writeCompressed = writeCompressed Me.m_firstFrame = 0 End Sub ''' <summary>Copy a palette</summary> ''' <param name="template">Original palette</param> Private Sub CopyPalette(template As ColorPalette) Me.m_palette = New Avi.RGBQUAD(template.Entries.Length - 1) {} For n As Integer = 0 To Me.m_palette.Length - 1 If n < template.Entries.Length Then Me.m_palette(n).rgbRed = template.Entries(n).R Me.m_palette(n).rgbGreen = template.Entries(n).G Me.m_palette(n).rgbBlue = template.Entries(n).B Else Me.m_palette(n).rgbRed = 0 Me.m_palette(n).rgbGreen = 0 Me.m_palette(n).rgbBlue = 0 End If Next End Sub ''' <summary>Copy a palette</summary> ''' <param name="template">Original palette</param> Private Sub CopyPalette(template As Avi.RGBQUAD()) Me.m_palette = New Avi.RGBQUAD(template.Length - 1) {} For n As Integer = 0 To Me.m_palette.Length - 1 If n < template.Length Then Me.m_palette(n).rgbRed = template(n).rgbRed Me.m_palette(n).rgbGreen = template(n).rgbGreen Me.m_palette(n).rgbBlue = template(n).rgbBlue Else Me.m_palette(n).rgbRed = 0 Me.m_palette(n).rgbGreen = 0 Me.m_palette(n).rgbBlue = 0 End If Next End Sub ''' <summary>Initialize a new VideoStream</summary> ''' <remarks>Used only by constructors</remarks> ''' <param name="aviFile">The file that contains the stream</param> ''' <param name="writeCompressed">true: create a compressed stream before adding frames</param> ''' <param name="frameRate">Frames per second</param> ''' <param name="firstFrameBitmap">Image to write into the stream as the first frame</param> Private Sub Initialize(aviFile As Integer, writeCompressed As Boolean, frameRate As Double, firstFrameBitmap As Bitmap) Me.m_aviFile = aviFile Me.m_writeCompressed = writeCompressed Me.m_frameRate = frameRate Me.m_firstFrame = 0 CopyPalette(firstFrameBitmap.Palette) Dim bmpData As BitmapData = firstFrameBitmap.LockBits(New Rectangle(0, 0, firstFrameBitmap.Width, firstFrameBitmap.Height), ImageLockMode.[ReadOnly], firstFrameBitmap.PixelFormat) Me.m_frameSize = bmpData.Stride * bmpData.Height Me.m_width = firstFrameBitmap.Width Me.m_height = firstFrameBitmap.Height Me.m_countBitsPerPixel = ConvertPixelFormatToBitCount(firstFrameBitmap.PixelFormat) firstFrameBitmap.UnlockBits(bmpData) End Sub ''' <summary>Get the count of bits per pixel from a PixelFormat value</summary> ''' <param name="format">One of the PixelFormat members beginning with "Format..." - all others are not supported</param> ''' <returns>bit count</returns> Private Function ConvertPixelFormatToBitCount(format As PixelFormat) As Int16 Dim formatName As [String] = format.ToString() If formatName.Substring(0, 6) <> "Format" Then Throw New Exception("Unknown pixel format: " & formatName) End If formatName = formatName.Substring(6, 2) Dim bitCount As Int16 = 0 If [Char].IsNumber(formatName(1)) Then ' 16, 32, 48 bitCount = Int16.Parse(formatName) Else ' 4, 8 bitCount = Int16.Parse(formatName(0).ToString()) End If Return bitCount End Function ''' <summary>Returns a PixelFormat value for a specific bit count</summary> ''' <param name="bitCount">count of bits per pixel</param> ''' <returns>A PixelFormat value for [bitCount]</returns> Private Function ConvertBitCountToPixelFormat(bitCount As Integer) As PixelFormat Dim formatName As [String] If bitCount > 16 Then formatName = [String].Format("Format{0}bppRgb", bitCount) ElseIf bitCount = 16 Then formatName = "Format16bppRgb555" Else ' < 16 formatName = [String].Format("Format{0}bppIndexed", bitCount) End If Return CType([Enum].Parse(GetType(PixelFormat), formatName), PixelFormat) End Function Private Function GetStreamInfo(aviStream As IntPtr) As Avi.AVISTREAMINFO Dim streamInfo As New Avi.AVISTREAMINFO() Dim result As Integer = Avi.AVIStreamInfo_(StreamPointer, streamInfo, Marshal.SizeOf(streamInfo)) If result <> 0 Then Throw New Exception("Exception in VideoStreamInfo: " & result.ToString()) End If Return streamInfo End Function Private Sub GetRateAndScale(ByRef frameRate As Double, ByRef scale As Integer) scale = 1 While frameRate <> CLng(Math.Truncate(frameRate)) frameRate = frameRate * 10 scale *= 10 End While End Sub ''' <summary>Create a new stream</summary> Private Sub CreateStreamWithoutFormat() Dim scale As Integer = 1 Dim rate As Double = m_frameRate GetRateAndScale(rate, scale) Dim strhdr As New Avi.AVISTREAMINFO() strhdr.fccType = Avi.mmioStringToFOURCC("vids", 0) strhdr.fccHandler = Avi.mmioStringToFOURCC("CVID", 0) strhdr.dwFlags = 0 strhdr.dwCaps = 0 strhdr.wPriority = 0 strhdr.wLanguage = 0 strhdr.dwScale = CInt(scale) strhdr.dwRate = CInt(Math.Truncate(rate)) ' Frames per Second strhdr.dwStart = 0 strhdr.dwLength = 0 strhdr.dwInitialFrames = 0 strhdr.dwSuggestedBufferSize = m_frameSize 'height_ * stride_; strhdr.dwQuality = -1 ' Default strhdr.dwSampleSize = 0 strhdr.rcFrame.top = 0 strhdr.rcFrame.left = 0 strhdr.rcFrame.bottom = CUInt(m_height) strhdr.rcFrame.right = CUInt(m_width) strhdr.dwEditCount = 0 strhdr.dwFormatChangeCount = 0 strhdr.szName = New UInt16(63) {} Dim result As Integer = Avi.AVIFileCreateStream(m_aviFile, m_aviStream, strhdr) If result <> 0 Then Throw New Exception("Exception in AVIFileCreateStream: " & result.ToString()) End If End Sub ''' <summary>Create a new stream</summary> Private Sub CreateStream() CreateStreamWithoutFormat() If WriteCompressed Then CreateCompressedStream() 'SetFormat(aviStream, 0); Else End If End Sub ''' <summary>Create a new stream</summary> Private Sub CreateStream(options As Avi.AVICOMPRESSOPTIONS) CreateStreamWithoutFormat() CreateCompressedStream(options) End Sub ''' <summary>Create a compressed stream from an uncompressed stream</summary> Private Sub CreateCompressedStream() ' Display the compression options dialog... Dim options As New Avi.AVICOMPRESSOPTIONS_CLASS() ' http://www.fourcc.org/codecs.php ' Formats compatibles YouTube : ' http://support.google.com/youtube/troubleshooter/2888402 ' vids = flux vidéo, quel que soit le codec, ne pas changer options.fccType = CUInt(Avi.mmioStringToFOURCC(typeFlux.sTypeVideo, 0)) 'Debug.WriteLine("options.fccType=" & options.fccType) ' Equivalent : 'options.fccType = CUInt(Avi.streamtypeVIDEO_VIDS) 'Debug.WriteLine("options.fccType=" & options.fccType) ' Ok, mais avec YouTube, ne marche plus à 100% : options.fccHandler = CUInt(Avi.mmioStringToFOURCC("CVID", 0)) ' Cinépack codec : ok ! ' -> 'options.fccHandler = 1145656899 'options.fccHandler = CUInt(Avi.mmioStringToFOURCC("DIVX", 0)) ' Ok ! ' Angelpotion Codec - vids:mp4, vids:mp42, mpeg4v3 and vids:mp43 'options.fccHandler = CUInt(Avi.mmioStringToFOURCC("MP42", 0)) ' BUG 'options.fccHandler = 1668707181 ' MS vidéo 1 : Ok, mais très compressé ! 'options.fccHandler = 1987410281 ' Intel 1 N&B ! 'options.fccHandler = 808596585 ' Intel 2 N&B ! 'Debug.WriteLine("Cinépack par le code :") 'Debug.WriteLine("options.fccHandler=" & options.fccHandler) ' Cinépack de radius, via l'interface, pas le même codec que CVID ? Pareil ! 'options.fccHandler = 1684633187 'options.dwQuality = 10000 ' 28/03/2015 Pareil ! ' Utiliser les prm de cette struct. au lieu de la valeur par défaut 'options.dwFlags = Avi.AVICOMPRESSF_VALID ' Pareil 'options.dwFlags = _ ' Avi.AVICOMPRESSF_INTERLEAVE Or _ ' Avi.AVICOMPRESSF_DATARATE Or _ ' Avi.AVICOMPRESSF_KEYFRAMES Or _ ' Avi.AVICOMPRESSF_VALID() 'options.fccHandler = CUInt(Avi.mmioStringToFOURCC("CVID", 0)) 'Debug.WriteLine("options.fccHandler=" & options.fccHandler) 'options.fccHandler = CUInt(Avi.mmioStringToFOURCC("MPG4", 0)) 'Debug.WriteLine("options.fccHandler=" & options.fccHandler) 'options.fccHandler = CUInt(Avi.mmioStringToFOURCC("MRLE", 0)) ' BUG 'options.fccHandler = CUInt(Avi.mmioStringToFOURCC("XVID", 0)) ' BUG 'options.fccHandler = CUInt(Avi.mmioStringToFOURCC("VIDS", 0)) ' BUG options.lpParms = IntPtr.Zero options.lpFormat = IntPtr.Zero ' Affiche la boite de dlg 'Avi.AVISaveOptions(IntPtr.Zero, Avi.ICMF_CHOOSE_KEYFRAME Or _ ' Avi.ICMF_CHOOSE_DATARATE, 1, m_aviStream, options) 'Debug.WriteLine("Cinépack par l'interface :") 'Debug.WriteLine("options.fccHandler=" & options.fccHandler) ' get the compressed stream Me.m_compressOptions = options.ToStruct() Dim result As Integer = Avi.AVIMakeCompressedStream(m_compressedStream, m_aviStream, m_compressOptions, 0) If result <> 0 Then Throw New Exception("Exception in AVIMakeCompressedStream: " & result.ToString()) End If Avi.AVISaveOptionsFree(1, options) SetFormat(m_compressedStream, 0) End Sub ''' <summary>Create a compressed stream from an uncompressed stream</summary> Private Sub CreateCompressedStream(options As Avi.AVICOMPRESSOPTIONS) Dim result As Integer = Avi.AVIMakeCompressedStream(m_compressedStream, m_aviStream, options, 0) If result <> 0 Then Throw New Exception("Exception in AVIMakeCompressedStream: " & result.ToString()) End If Me.m_compressOptions = options SetFormat(m_compressedStream, 0) End Sub ''' <summary>Add one frame to a new stream</summary> ''' <param name="bmp"></param> ''' <remarks> ''' This works only with uncompressed streams, ''' and compressed streams that have not been saved yet. ''' Use DecompressToNewFile to edit saved compressed streams. ''' </remarks> Public Sub AddFrame(bmp As Bitmap) bmp.RotateFlip(RotateFlipType.RotateNoneFlipY) ' NEW 2012-11-10 If m_countFrames = 0 Then CopyPalette(bmp.Palette) SetFormat(If(WriteCompressed, m_compressedStream, StreamPointer), m_countFrames) End If Dim bmpDat As BitmapData = bmp.LockBits(New Rectangle(0, 0, bmp.Width, bmp.Height), ImageLockMode.[ReadOnly], bmp.PixelFormat) Dim result As Integer = Avi.AVIStreamWrite( If(WriteCompressed, m_compressedStream, StreamPointer), m_countFrames, 1, bmpDat.Scan0, CType(bmpDat.Stride * bmpDat.Height, Int32), 0, 0, 0) If result <> 0 Then Throw New Exception("Exception in VideoStreamWrite: " & result.ToString()) End If bmp.UnlockBits(bmpDat) m_countFrames += 1 End Sub ''' <summary>Apply a format to a new stream</summary> ''' <param name="aviStream">The IAVISTREAM</param> ''' <remarks> ''' The format must be set before the first frame can be written, ''' and it cannot be changed later. ''' </remarks> Private Sub SetFormat(aviStream As IntPtr, writePosition As Integer) Dim bi As New Avi.BITMAPINFO() bi.bmiHeader.biWidth = m_width bi.bmiHeader.biHeight = m_height bi.bmiHeader.biPlanes = 1 bi.bmiHeader.biBitCount = m_countBitsPerPixel bi.bmiHeader.biSizeImage = m_frameSize bi.bmiHeader.biSize = Marshal.SizeOf(bi.bmiHeader) If m_countBitsPerPixel < 24 Then bi.bmiHeader.biClrUsed = Me.m_palette.Length bi.bmiHeader.biClrImportant = Me.m_palette.Length bi.bmiColors = New Avi.RGBQUAD(Me.m_palette.Length - 1) {} Me.m_palette.CopyTo(bi.bmiColors, 0) bi.bmiHeader.biSize += bi.bmiColors.Length * Avi.RGBQUAD_SIZE End If Dim result As Integer = Avi.AVIStreamSetFormat(aviStream, writePosition, bi, bi.bmiHeader.biSize) If result <> 0 Then Throw New Exception("Error in VideoStreamSetFormat: " & result.ToString("X")) End If End Sub ''' <summary>Prepare for decompressing frames</summary> ''' <remarks> ''' This method has to be called before GetBitmap and ExportBitmap. ''' Release ressources with GetFrameClose. ''' </remarks> Public Sub GetFrameOpen() Dim streamInfo As Avi.AVISTREAMINFO = GetStreamInfo(StreamPointer) ' Open frames Dim bih As New Avi.BITMAPINFOHEADER() bih.biBitCount = m_countBitsPerPixel bih.biClrImportant = 0 bih.biClrUsed = 0 bih.biCompression = 0 bih.biPlanes = 1 bih.biSize = Marshal.SizeOf(bih) bih.biXPelsPerMeter = 0 bih.biYPelsPerMeter = 0 ' Corrections by M. Covington: ' If these are pre-set, interlaced video is not handled correctly. ' Better to give zeroes and let Windows fill them in. bih.biHeight = 0 ' was (Int32)streamInfo.rcFrame.bottom; bih.biWidth = 0 ' was (Int32)streamInfo.rcFrame.right; ' Corrections by M. Covington: ' Validate the bit count, because some AVI files give a bit count ' that is not one of the allowed values in a BitmapInfoHeader. ' Here 0 means for Windows to figure it out from other information. If bih.biBitCount > 24 Then bih.biBitCount = 32 ElseIf bih.biBitCount > 16 Then bih.biBitCount = 24 ElseIf bih.biBitCount > 8 Then bih.biBitCount = 16 ElseIf bih.biBitCount > 4 Then bih.biBitCount = 8 ElseIf bih.biBitCount > 0 Then bih.biBitCount = 4 End If getFrameObject = Avi.AVIStreamGetFrameOpen(StreamPointer, bih) If getFrameObject = 0 Then Throw New Exception("Exception in VideoStreamGetFrameOpen!") End If End Sub ''' <summary>Export a frame into a bitmap file</summary> ''' <param name="position">Position of the frame</param> ''' <param name="dstFileName">Name of the file to store the bitmap</param> Public Sub ExportBitmap(position As Integer, dstFileName As [String]) Dim bmp As Bitmap = GetBitmap(position) bmp.Save(dstFileName, ImageFormat.Bmp) bmp.Dispose() End Sub ''' <summary>Export a frame into a bitmap</summary> ''' <param name="position">Position of the frame</param> Public Function GetBitmap(position As Integer) As Bitmap If position > m_countFrames Then Throw New Exception("Invalid frame position: " & position) End If Dim streamInfo As Avi.AVISTREAMINFO = GetStreamInfo(StreamPointer) Dim bih As New Avi.BITMAPINFO() Dim headerSize As Integer = Marshal.SizeOf(bih.bmiHeader) ' Decompress the frame and return a pointer to the DIB Dim dib As Integer = Avi.AVIStreamGetFrame(getFrameObject, m_firstFrame + position) ' Copy the bitmap header into a managed struct bih.bmiColors = Me.m_palette bih.bmiHeader = DirectCast(Marshal.PtrToStructure(New IntPtr(dib), bih.bmiHeader.[GetType]()), Avi.BITMAPINFOHEADER) If bih.bmiHeader.biSizeImage < 1 Then Throw New Exception("Exception in VideoStreamGetFrame") End If ' Copy the image Dim framePaletteSize As Integer = bih.bmiHeader.biClrUsed * Avi.RGBQUAD_SIZE Dim bitmapData As Byte() = New Byte(bih.bmiHeader.biSizeImage - 1) {} Dim dibPointer As New IntPtr(dib + Marshal.SizeOf(bih.bmiHeader) + framePaletteSize) Marshal.Copy(dibPointer, bitmapData, 0, bih.bmiHeader.biSizeImage) ' Copy bitmap info Dim bitmapInfo As Byte() = New Byte(Marshal.SizeOf(bih) - 1) {} Dim ptr As IntPtr = Marshal.AllocHGlobal(bitmapInfo.Length) Marshal.StructureToPtr(bih, ptr, False) Marshal.Copy(ptr, bitmapInfo, 0, bitmapInfo.Length) Marshal.FreeHGlobal(ptr) ' Create file header Dim bfh As New Avi.BITMAPFILEHEADER() bfh.bfType = Avi.BMP_MAGIC_COOKIE bfh.bfSize = CType(55 + bih.bmiHeader.biSizeImage, Int32) ' Size of file as written to disk bfh.bfReserved1 = 0 bfh.bfReserved2 = 0 bfh.bfOffBits = Marshal.SizeOf(bih) + Marshal.SizeOf(bfh) If bih.bmiHeader.biBitCount < 8 Then ' There is a palette between header and pixel data 'Avi.PALETTE_SIZE; bfh.bfOffBits += bih.bmiHeader.biClrUsed * Avi.RGBQUAD_SIZE End If ' Write a bitmap stream Dim bw As New BinaryWriter(New MemoryStream()) ' Write header bw.Write(bfh.bfType) bw.Write(bfh.bfSize) bw.Write(bfh.bfReserved1) bw.Write(bfh.bfReserved2) bw.Write(bfh.bfOffBits) ' Write bitmap info bw.Write(bitmapInfo) ' Write bitmap data bw.Write(bitmapData) Dim bmp As Bitmap = DirectCast(Image.FromStream(bw.BaseStream), Bitmap) Dim saveableBitmap As New Bitmap(bmp.Width, bmp.Height) Dim g As Graphics = Graphics.FromImage(saveableBitmap) g.DrawImage(bmp, 0, 0) g.Dispose() bmp.Dispose() bw.Close() Return saveableBitmap End Function ''' <summary>Free ressources that have been used by GetFrameOpen</summary> Public Sub GetFrameClose() If getFrameObject <> 0 Then Avi.AVIStreamGetFrameClose(getFrameObject) getFrameObject = 0 End If End Sub ''' <summary>Copy all frames into a new file</summary> ''' <param name="fileName">Name of the new file</param> ''' <param name="recompress">true: Compress the new stream</param> ''' <returns>AviManager for the new file</returns> ''' <remarks>Use this method if you want to append frames to an existing, compressed stream</remarks> Public Function DecompressToNewFile(fileName As [String], recompress As Boolean, ByRef newStream2 As VideoStream) As AviManager Dim newFile As New AviManager(fileName, False) Me.GetFrameOpen() Dim frame As Bitmap = GetBitmap(0) Dim newStream As VideoStream = newFile.AddVideoStream(recompress, m_frameRate, frame) frame.Dispose() For n As Integer = 1 To m_countFrames - 1 frame = GetBitmap(n) newStream.AddFrame(frame) frame.Dispose() Next Me.GetFrameClose() newStream2 = newStream Return newFile End Function ''' <summary>Copy the stream into a new file</summary> ''' <param name="fileName">Name of the new file</param> Public Overrides Sub ExportStream(fileName As [String]) Dim opts As New Avi.AVICOMPRESSOPTIONS_CLASS() opts.fccType = CUInt(Avi.streamtypeVIDEO_VIDS) opts.lpParms = IntPtr.Zero opts.lpFormat = IntPtr.Zero Dim streamPointer__1 As IntPtr = StreamPointer Avi.AVISaveOptions(IntPtr.Zero, Avi.ICMF_CHOOSE_KEYFRAME Or Avi.ICMF_CHOOSE_DATARATE, 1, streamPointer__1, opts) Avi.AVISaveOptionsFree(1, opts) Avi.AVISaveV(fileName, 0, 0, 1, m_aviStream, opts) End Sub End Class End Namespace clsFract.vb ' Fichier clsFract.vb ' ------------------- Imports System.Collections.Generic Public Class clsFract #Region "Constantes" ' Constantes par défaut Protected Const iPasMax% = 1 ' 2 : Pavé de 2x2 pixels Protected Const iPasMin% = 1 ' 1 pixel 'Protected Const iPasMax% = 4 'Protected Const iPasMin% = 4 Public Const bDecimalDef As Boolean = False ' False Public m_bDecimal As Boolean = bDecimalDef Public Const bLisserDef As Boolean = False ' False Public m_bLisser As Boolean = bLisserDef ' Si clsFractRapide, cela n'est pas désactivable Public Const bAlgoRapideDef As Boolean = True Public m_bAlgoRapide As Boolean = bAlgoRapideDef ' Si on met False, on interpole les couleurs là où l'on sort du cercle ' (dépassement des itérations max.) Public Const bFrontiereUnieDef As Boolean = False ' False ' En mode Strict On, As doit être utilisé 'Public Const typeFractDef As TFractal = TFractal.Mandelbrot ' Défaut 'Public Const bPaletteSystemeDef As Boolean = False 'True ' False 'Public Const typeFractDef As TFractal = TFractal.Julia Public Const typeFractDef As TFractal = TFractal.MandelbrotEtJulia Public Const bPaletteSystemeDef As Boolean = True ' Shared : les instances de classe constantes doivent être partagées Public Shared ptfJuliaDef As PointF = New PointF(0, 0) ' MandelbrotJulia 'Public Shared ptfJuliaDef As PointF = New PointF(0, 1.95) 'Public Shared ptfJuliaDef As PointF = New PointF(-6, 0.8) 'Public Shared ptfJuliaDef As PointF = New PointF(6, 0.8) 'Public Shared ptfJuliaDef As PointF = New PointF(-8, 1.8) Public Const iDegreAlgoDef% = 2 ' Z -> Z^2 + C par défaut Public m_bEffacerImgDef As Boolean = False 'True Public Const rAmplitudeMinOkDouble# = 0.00000000000005 ' 5E-14 en Double Public Const rAmplitudeMinOkDecimal As Decimal = CDec(2.0E-25) ' 2E-25 en Decimal Public Const iNbIterationsMaxDepartDef% = 128 ' Petit zoom avec les flèches Private Const rDeltaZoom As Decimal = 0.01D Public Const rFactPetitZoomMoins As Decimal = 1 + rDeltaZoom '1.02D '1.05D Public Const rFactPetitZoomPlus As Decimal = 1 - rDeltaZoom '0.98D '0.95D Public Const rPetitDeplacement As Decimal = 0.01D Public Const rPetitDeplacementJulia As Decimal = 0.001D Public Const rTresPetitDeplacementJulia As Decimal = 0.00001D ' 08/02/2015 En mode cible, afficher le % log du zoom Public m_bModeCible As Boolean = False ' 25/01/2015 En mode zoom - ne pas augmenter le nombre d'itération max. Public m_bZoomMoins As Boolean = False ' Zoom par défaut en coordonnées absolues ' cercle entier visible à l'écran : rZoomDef = 2 Public Const rZoomDef As Decimal = 2 ' Pour un zoom arrière, on multiplie par 2 l'amplitude actuelle ' en coord. abs de l'image Public Const rFacteurZoomMoins As Decimal = 2 Public Const bPaletteAleatoireDef As Boolean = False ' Commencer le modulo par la 10ème couleur (pour éviter le blanc, ' qui est déjà utilisé pour le détail des itérations) Public Const iPremCouleurDef% = 10 Public Const iCouleurMaxDef% = KnownColor.YellowGreen ' = 167 '4 ' Nombre de couleur max. dans la palette 768 : réduction de palette progressive si la division progresse ' 768/1 : 768 dégradés de couleurs ' 768/2 : 384 ' 768/4 : 192 ' 768/8 : 96 ' 768/16 : 48 -> 3, 4, 6 ou 8 zones ' 768/32 : 24 -> 3 ou 4 zones ' 768/64 : 12 -> 3 ou 4 zones ' 768/128 : 6 -> 1 zone ' 768/256 : 3 -> 1 zone Public Const iNbCyclesPaletteDef% = 4 '1 '32 '2 '32 max. ' 0 : Non examiné, 1 : frontière, 2 à n : palette effective Protected Const iNbCouleursReservees% = 2 Protected Const iCodePixelNonExamine% = 0 ' Par convention, 1 est le code d'un pixel frontière : NbItérations max. Protected Const iCodePixelFrontiere% = 1 Protected Const iCodePixelDessin% = 2 Protected Const iIntegerMax% = Integer.MaxValue ' System.Int32.MaxValue ' = 2147483647 #End Region #Region "Déclarations" ' Gestion des événements qui seront récupérés depuis la feuille principale ' (cela évite la méthode bourrine consistant à passer la feuille principale ' en propriété et à appeler directement ses méthodes :-) Public Event EvMajBmp() Public Event EvMajAvancement(iAvancement%) Public Event EvFinTrace() Public Event EvDetailIterations(aPt() As Point) Protected m_bModeTranslation As Boolean Protected m_bModeDetailIterations As Boolean Public m_bEffacerImg As Boolean Protected m_szTailleEcran As New Size() ' Dimension du tracé en pixels Public m_bQuitterTrace As Boolean ' Pour quitter + vite le thread Protected m_gr As Graphics ' Graphique de tracé dans le bitmap de cache Public m_iNbCouleurs% Private m_aiCouleurs%() Protected m_remplissage As New SolidBrush(Color.Black) Public m_prmPalette As TPrmPalette ' Faire une pause dans le tracé pour récupérer du temps ' (alternative au thread) Public m_bPause As Boolean 'Public m_bStop As Boolean #Region "Gestion du niveau d'itération pour le zoom -" Public Class clsCoupleLogIter Public rLog#, iNbIter% Public Sub New(rLog0#, iNbIter0%) rLog = rLog0 iNbIter = iNbIter0 End Sub End Class Private m_lstNivIter As List(Of clsCoupleLogIter) Private Sub InitNivIter() m_lstNivIter = New List(Of clsCoupleLogIter) End Sub Private Sub AjouterNivIter(couple As clsCoupleLogIter) ' Ajouter un couple à la fin tant que le log est plus petit ' sinon couper la fin Dim lstNivIter As New List(Of clsCoupleLogIter) For Each couple0 As clsCoupleLogIter In m_lstNivIter If couple.rLog > couple0.rLog Then Exit For lstNivIter.Add(couple0) Next lstNivIter.Add(couple) m_lstNivIter = lstNivIter End Sub Private Function iTrouverNivIter%(rLog#) ' Retourner le nombre d'itération correspondant au log de l'amplitude de dessin Dim iNbIter% = 0 Dim iMemNbIter% = 0 Dim rMemLog# = 0 For Each couple0 As clsCoupleLogIter In m_lstNivIter iNbIter = couple0.iNbIter If couple0.rLog <= rLog Then ' Faire une règle de 3 si possible If rMemLog <> 0 Then Dim rNbIterMoy# = iMemNbIter + (rLog - rMemLog) * (iNbIter - iMemNbIter) / (couple0.rLog - rMemLog) Return CInt(rNbIterMoy) End If Return iNbIter End If rMemLog = couple0.rLog iMemNbIter = iNbIter Next Return iNbIter End Function #End Region Public Structure TPrmFract ' Paramètres de tracé Dim iDegre% ' Degré de l'équation Z -> Z^Degré + C Dim iNbIterationsMaxDepart% ' Itérations max. au départ du zoom Dim typeFract As TFractal ' Type Mandelbrot ou Julia ' Pour les ensembles de Julia : Parties réelle et imag. du complexe Z Dim rRe, rIm As Decimal Dim rAngle, rRayon As Decimal ' Pour faire bouger le point Julia Dim rDeltaAngle As Decimal Dim rAngleZoom As Decimal ' Algo rapide ' ----------- Dim rXd, rYd As Decimal ' Pour algo. rapide Dim coulInterpolee As Color ' ----------- End Structure Public m_prm As TPrmFract Public m_iNbIterationsMin% ' Itérations min. constatés après un tracé Public m_iNbIterationsMax% ' Itérations max. pour un tracé Public m_iMemNbIterationsMin% Public m_cf As TCoordFract ' Classe pour gérer l'affichage du détail des itérations ' de l'équation sur un pixel Private Class clsDetailIterations Private m_iNbPts% Private m_aPt() As Point Public Sub Initialiser() m_iNbPts = 0 End Sub Public Sub AjouterPointDetailIterations(a As Double, b As Double, ByRef cf As TCoordFract) If cf.rLargPaveAbs = 0 Or cf.rHautPaveAbs = 0 Then Exit Sub Dim pt As Point pt.X = CInt(cf.iMargeX + iPasMin * (a - cf.rCoordAbsXMin) / cf.rLargPaveAbs + iPasMin \ 2) pt.Y = CInt(cf.iMargeY + iPasMin * (b - cf.rCoordAbsYMin) / cf.rHautPaveAbs + iPasMin \ 2) ReDim Preserve m_aPt(m_iNbPts) m_aPt(m_iNbPts) = pt m_iNbPts += 1 End Sub Public Function aptLirePoint() As Point() aptLirePoint = m_aPt End Function End Class Private m_oDetailIter As New clsDetailIterations() #End Region #Region "Propriétés" Public Property szTailleEcran() As Size Get Return m_szTailleEcran End Get Set(szVal As Size) m_szTailleEcran = szVal End Set End Property Public WriteOnly Property Gr() As Graphics Set(gr As Graphics) m_gr = gr ' Pas de différence constatée m_gr.SmoothingMode = Drawing2D.SmoothingMode.HighSpeed m_gr.PixelOffsetMode = Drawing2D.PixelOffsetMode.HighSpeed 'm_gr.QualityMode = Drawing2D.QualityMode.Low ' Non trouvé ? End Set End Property Public Property bQuitterTrace() As Boolean Get Return m_bQuitterTrace End Get Set(bVal As Boolean) m_bQuitterTrace = bVal End Set End Property Public Property typeFrac As TFractal Get Return m_prm.typeFract End Get Set(bVal As TFractal) m_prm.typeFract = bVal 'Select Case bVal 'Case TFractal.Mandelbrot 'Case TFractal.Julia 'Case TFractal.MandelbrotEtJulia 'End Select End Set End Property Public Property bJulia() As Boolean Get Return (m_prm.typeFract = TFractal.Julia OrElse m_prm.typeFract = TFractal.MandelbrotEtJulia) End Get Set(bVal As Boolean) m_prm.typeFract = TFractal.Mandelbrot If bVal Then m_prm.typeFract = TFractal.Julia End Set End Property Public Property ptfJulia() As PointF Get ptfJulia.X = m_prm.rRe ptfJulia.Y = m_prm.rIm End Get Set(ptf As PointF) m_prm.rRe = CDec(ptf.X) m_prm.rIm = CDec(ptf.Y) End Set End Property Public Property iDegre%() Get Return m_prm.iDegre End Get Set(iVal%) m_prm.iDegre = iVal End Set End Property Public Property iNbIterationsMaxDepart%() Get Return m_prm.iNbIterationsMaxDepart End Get Set(iVal%) m_prm.iNbIterationsMaxDepart = iVal End Set End Property Public ReadOnly Property iNbIterationsMax%() Get Return m_iNbIterationsMax End Get End Property Public ReadOnly Property iNbIterationsMin%() Get Return m_iNbIterationsMin End Get End Property Public Property bModeDetailIterations() As Boolean Get Return m_bModeDetailIterations End Get Set(bVal As Boolean) m_bModeDetailIterations = bVal End Set End Property Public Property bModeTranslation() As Boolean Get Return m_bModeTranslation End Get Set(bVal As Boolean) m_bModeTranslation = bVal End Set End Property Public Property bEffacerImg() As Boolean Get Return m_bEffacerImg End Get Set(bVal As Boolean) m_bEffacerImg = bVal End Set End Property Public ReadOnly Property rCentreX() As Decimal Get Return (m_cf.rCoordAbsXMax + m_cf.rCoordAbsXMin) / 2 End Get End Property Public ReadOnly Property rCentreY() As Decimal Get Return (m_cf.rCoordAbsYMax + m_cf.rCoordAbsYMin) / 2 End Get End Property Public ReadOnly Property rAmplitX() As Decimal Get Return m_cf.rCoordAbsXMax - m_cf.rCoordAbsXMin End Get End Property Public ReadOnly Property rAmplitY() As Decimal Get Return m_cf.rCoordAbsYMax - m_cf.rCoordAbsYMin End Get End Property #End Region #Region "Tracé des images fractales" Public Sub InitialiserPrmFract() m_cf.rCoordAbsXMin = -rZoomDef : m_cf.rCoordAbsXMax = rZoomDef m_cf.rCoordAbsYMin = -rZoomDef : m_cf.rCoordAbsYMax = rZoomDef ' Test Bug QuadTree Dim iNbIterationsMaxDepartDef0% = iNbIterationsMaxDepartDef If bDebugBugQuad Then m_cf.rCoordAbsXMin = -0.5D m_cf.rCoordAbsXMax = 0.1D m_cf.rCoordAbsYMin = -0.5D m_cf.rCoordAbsYMax = 0.5D End If RespecterRatioZoneAbs() InitNivIter() m_prm.typeFract = typeFractDef m_prm.rRe = CDec(ptfJuliaDef.X) m_prm.rIm = CDec(ptfJuliaDef.Y) m_prm.iDegre = iDegreAlgoDef m_prm.iNbIterationsMaxDepart = iNbIterationsMaxDepartDef0 m_iNbIterationsMin = 0 m_bEffacerImg = m_bEffacerImgDef CalculerNbCouleurs() If Not m_prmPalette.bPaletteSysteme Then InitPaletteCalc() m_bZoomMoins = False ' 25/01/2015 End Sub Public Function rLirePointJuliaX() As Decimal Return m_prm.rRe End Function Public Function rLirePointJuliaY() As Decimal Return m_prm.rIm End Function Public Overridable Sub InitConfig() End Sub Public Overridable Sub InitPalette() End Sub Public Sub InitialiserIterations() m_iNbIterationsMin = 0 End Sub Public Sub ZoomerZonePixels(m_rectCoordPixels As Rectangle) ' Calcul des nouvelles coordonnées absolues Dim rNewCoordAbsXMin As Decimal = CDec(m_rectCoordPixels.Left / m_szTailleEcran.Width) Dim rNewCoordAbsYMin As Decimal = CDec(m_rectCoordPixels.Top / m_szTailleEcran.Height) Dim rNewCoordAbsXMax As Decimal = CDec((m_rectCoordPixels.Left + m_rectCoordPixels.Width) / m_szTailleEcran.Width) Dim rNewCoordAbsYMax As Decimal = CDec((m_rectCoordPixels.Top + m_rectCoordPixels.Height) / m_szTailleEcran.Height) ' Ancienne amplitude absolue Dim rAncAmplitX As Decimal = m_cf.rCoordAbsXMax - m_cf.rCoordAbsXMin Dim rAncAmplitY As Decimal = m_cf.rCoordAbsYMax - m_cf.rCoordAbsYMin m_cf.rCoordAbsXMax = m_cf.rCoordAbsXMin + rNewCoordAbsXMax * rAncAmplitX m_cf.rCoordAbsYMax = m_cf.rCoordAbsYMin + rNewCoordAbsYMax * rAncAmplitY m_cf.rCoordAbsXMin = m_cf.rCoordAbsXMin + rNewCoordAbsXMin * rAncAmplitX m_cf.rCoordAbsYMin = m_cf.rCoordAbsYMin + rNewCoordAbsYMin * rAncAmplitY RespecterRatioZoneAbs() End Sub Public Sub RespecterRatioZoneAbs() ' Attention : il faut conserver le ratio quelque soit celui de l'écran If m_szTailleEcran.Height >= m_szTailleEcran.Width Then ' Ratio <=1 If m_szTailleEcran.Width <> 0 Then ' Centre du zoom Dim rCentreY0 As Decimal = (m_cf.rCoordAbsYMax + m_cf.rCoordAbsYMin) / 2 ' Ratio inverse : Hauteur sur Largeur : si le ratio normal est de 0.5 ' alors le ratio inverse est de 2 Dim rRatioEcranHSurL As Decimal = CDec(m_szTailleEcran.Height / m_szTailleEcran.Width) Dim rDepY As Decimal = (m_cf.rCoordAbsXMax - m_cf.rCoordAbsXMin) * rRatioEcranHSurL m_cf.rCoordAbsYMin = rCentreY0 - rDepY / 2 m_cf.rCoordAbsYMax = rCentreY0 + rDepY / 2 End If Else ' Ratio >1 If m_szTailleEcran.Height <> 0 Then ' Centre du zoom Dim rCentreX0 As Decimal = (m_cf.rCoordAbsXMax + m_cf.rCoordAbsXMin) / 2 Dim rRatioEcran As Decimal = CDec(m_szTailleEcran.Width / m_szTailleEcran.Height) Dim rDepX As Decimal = (m_cf.rCoordAbsYMax - m_cf.rCoordAbsYMin) * rRatioEcran m_cf.rCoordAbsXMin = rCentreX0 - rDepX / 2 m_cf.rCoordAbsXMax = rCentreX0 + rDepX / 2 End If End If End Sub Public Sub ZoomerFacteur(rFacteurZoom As Decimal, bZoomMoins As Boolean) If rFacteurZoom = 1D Then Exit Sub ' Centre du zoom Dim rCentreX As Decimal = (m_cf.rCoordAbsXMax + m_cf.rCoordAbsXMin) / 2 Dim rCentreY As Decimal = (m_cf.rCoordAbsYMax + m_cf.rCoordAbsYMin) / 2 ' Amplitude actuelle du zoom Dim rAmplitX0 As Decimal = m_cf.rCoordAbsXMax - m_cf.rCoordAbsXMin Dim rAmplitY0 As Decimal = m_cf.rCoordAbsYMax - m_cf.rCoordAbsYMin ' Reculer le zoom m_cf.rCoordAbsXMin = rCentreX - rAmplitX0 * rFacteurZoom / 2 m_cf.rCoordAbsXMax = rCentreX + rAmplitX0 * rFacteurZoom / 2 m_cf.rCoordAbsYMin = rCentreY - rAmplitY0 * rFacteurZoom / 2 m_cf.rCoordAbsYMax = rCentreY + rAmplitY0 * rFacteurZoom / 2 If bZoomMoins Then ' Diminuer le nombre d'itération minimum Dim W As Decimal = m_cf.rCoordAbsXMax - m_cf.rCoordAbsXMin Dim rLogW# = Math.Log10(W) m_iNbIterationsMin = iTrouverNivIter%(rLogW) Debug.WriteLine("Nb. itérations trouvé : " & rLogW & " -> " & m_iNbIterationsMin) m_bZoomMoins = True ' 21/01/2015 Else m_bZoomMoins = False ' 21/01/2015 End If End Sub Public Sub Zoomer(rFacteurZoom!) ' Centre du zoom Dim rCentreX As Decimal = (m_cf.rCoordAbsXMax + m_cf.rCoordAbsXMin) / 2 Dim rCentreY As Decimal = (m_cf.rCoordAbsYMax + m_cf.rCoordAbsYMin) / 2 ' Amplitude actuelle du zoom Dim rAmplitX As Decimal = m_cf.rCoordAbsXMax - m_cf.rCoordAbsXMin Dim rAmplitY As Decimal = m_cf.rCoordAbsYMax - m_cf.rCoordAbsYMin ' Zoomer Dim rFact As Decimal = CDec(rFacteurZoom) m_cf.rCoordAbsXMin = Me.rCentreX - rAmplitX * rFact / 2 m_cf.rCoordAbsXMax = Me.rCentreX + rAmplitX * rFact / 2 m_cf.rCoordAbsYMin = Me.rCentreY - rAmplitY * rFact / 2 m_cf.rCoordAbsYMax = Me.rCentreY + rAmplitY * rFact / 2 End Sub Public Sub Deplacer(rDepRelatifX!, rDepRelatifY!) ' Amplitude actuelle du zoom Dim rAmplitX As Decimal = m_cf.rCoordAbsXMax - m_cf.rCoordAbsXMin Dim rAmplitY As Decimal = m_cf.rCoordAbsYMax - m_cf.rCoordAbsYMin ' Déplacement asbolu Dim rDepX As Decimal = CDec(rDepRelatifX) * rAmplitX Dim rDepY As Decimal = CDec(rDepRelatifY) * rAmplitY m_cf.rCoordAbsXMin += rDepX m_cf.rCoordAbsXMax += rDepX m_cf.rCoordAbsYMin += rDepY m_cf.rCoordAbsYMax += rDepY End Sub Public Sub DeplacerPtJulia(rDepRelatifX!, rDepRelatifY!) m_prm.rRe += CDec(rDepRelatifX) m_prm.rIm += CDec(rDepRelatifY) End Sub Public Sub FixerAnglePtJulia(rDepRelatifAngle!) m_prm.rAngle += CDec(rDepRelatifAngle) End Sub Public Sub FixerAngleZoomPtJulia(rDepRelatifAngle!) m_prm.rAngleZoom += CDec(rDepRelatifAngle) End Sub Public Function rLireAngleZoomJulia() As Decimal Return m_prm.rAngleZoom End Function Public Sub TournerPtJulia() m_prm.rRayon = 1.1D m_prm.rRe = m_prm.rRayon * CDec(Math.Cos(m_prm.rAngle + Math.PI / 4)) m_prm.rIm = m_prm.rRayon * CDec(Math.Sin(m_prm.rAngle + Math.PI / 4)) End Sub Public Sub InitPtJulia() m_prm.rRe = 0 m_prm.rIm = 0 End Sub Public Sub ViserPoint(rCentreX0 As Decimal, rCentreY0 As Decimal, rZoomDepart As Decimal, iNbIter%, rZoomCible As Decimal) ' Définir la vue via une cible et un facteur de zoom Dim rRatioEcran As Decimal = CDec(m_szTailleEcran.Width / m_szTailleEcran.Height) Dim rDemiAmplitX As Decimal = rZoomDepart * rRatioEcran / 2 Dim rDemiAmplitY As Decimal = rZoomDepart / 2 m_cf.rCoordAbsXMin = rCentreX0 - rDemiAmplitX m_cf.rCoordAbsXMax = rCentreX0 + rDemiAmplitX m_cf.rCoordAbsYMin = rCentreY0 - rDemiAmplitY m_cf.rCoordAbsYMax = rCentreY0 + rDemiAmplitY m_iNbIterationsMin = iNbIter m_iNbIterationsMax = iNbIter + iNbIterationsMaxDepart m_cf.rZoomCible = rZoomCible End Sub Public Sub DefinirCible(rFacteurZoom!) ' Centre du zoom Dim rCentreX As Decimal = (m_cf.rCoordAbsXMax + m_cf.rCoordAbsXMin) / 2 Dim rCentreY As Decimal = (m_cf.rCoordAbsYMax + m_cf.rCoordAbsYMin) / 2 ' Amplitude actuelle du zoom Dim rAmplitX As Decimal = m_cf.rCoordAbsXMax - m_cf.rCoordAbsXMin Dim rAmplitY As Decimal = m_cf.rCoordAbsYMax - m_cf.rCoordAbsYMin ' Reculer le zoom Dim rFacteurZoomDec As Decimal = CDec(rFacteurZoom) m_cf.rCoordAbsXMin = rCentreX - rAmplitX * rFacteurZoomDec / 2 m_cf.rCoordAbsXMax = rCentreX + rAmplitX * rFacteurZoomDec / 2 m_cf.rCoordAbsYMin = rCentreY - rAmplitY * rFacteurZoomDec / 2 m_cf.rCoordAbsYMax = rCentreY + rAmplitY * rFacteurZoomDec / 2 End Sub Protected Sub InitTracerFractDepart() Me.m_bPause = False Me.m_bQuitterTrace = False Me.m_bModeDetailIterations = False End Sub Protected m_bmpCache As Bitmap Public Overridable Sub TracerFractDepart(bmpCache As Bitmap) Me.m_bmpCache = bmpCache InitTracerFractDepart() TracerFractProgressif() End Sub Protected Overridable Sub TracerFractProgressif() ' iNbIterationsMax dépend du nombre d'itérations min. précédant : ' cela évite de le définir trop élevé dès le début, alors que ' c'est seulement pour un zoom profond que l'on a besoin de ' beaucoup d'itérations 'Debug.WriteLine("m_iNbIterationsMin = " & m_iNbIterationsMin) 'Debug.WriteLine("m_iNbIterationsMax = " & m_iNbIterationsMax) 'Debug.WriteLine("m_iNbIterationsMaxDepart = " & m_prm.iNbIterationsMaxDepart) m_iMemNbIterationsMin = m_iNbIterationsMin ' 25/01/2015 En mode zoom - ne pas augmenter le nombre d'itération If Not m_bZoomMoins AndAlso m_iNbIterationsMin < iIntegerMax Then ' m_iNbIterationsMaxCible Dim iNouvMax% = m_prm.iNbIterationsMaxDepart + m_iNbIterationsMin ' 25/01/2015 En mode cible, ne pas redescendre en dessous de la cible m_iNbIterationsMax = iNouvMax End If m_bZoomMoins = False m_iNbIterationsMin = iIntegerMax InitialiserTracerFract() Dim W As Decimal = m_cf.rCoordAbsXMax - m_cf.rCoordAbsXMin Dim H As Decimal = m_cf.rCoordAbsYMax - m_cf.rCoordAbsYMin Dim rLogW# = Math.Log10(W) Dim rLogH# = Math.Log10(H) 'Debug.WriteLine("Nb iter.= " & m_iMemNbIterationsMin & " -> " & m_iNbIterationsMax & _ ' ", " & W & ", " & H & ", " & rLogW & ", " & rLogH) 'Debug.WriteLine("Ajout : " & rLogW & ", " & m_iMemNbIterationsMin) AjouterNivIter(New clsCoupleLogIter(rLogW, m_iMemNbIterationsMin)) ' Pour algo. rapide ' ----------------- Dim width% = m_szTailleEcran.Width Dim heigth% = m_szTailleEcran.Height Dim X2 As Decimal = (m_cf.rCoordAbsXMax + m_cf.rCoordAbsXMin) / 2 Dim Y2 As Decimal = (m_cf.rCoordAbsYMax + m_cf.rCoordAbsYMin) / 2 Dim xs As Decimal = X2 - (W / 2) Dim ys As Decimal = Y2 - (H / 2) m_prm.rXd = W / CDec(width) m_prm.rYd = H / CDec(heigth) ' ----------------- ' Pour algo rapide, pas besoin d'effacer If m_bEffacerImg Then m_gr.Clear(couleurFondCyan) RaiseEvent EvMajBmp() End If Dim iPas% = iPasMax Do InitCoordFract(m_cf, iPas) ' Pour cacher les gros pixels hors zone If m_bEffacerImg Then m_gr.Clear(couleurFondCyan) TracerFract(iPas) If m_bQuitterTrace Then GoTo Fin iPas \= 2 ' \ : Antislash = Division entière Loop While iPas >= iPasMin Fin: RaiseEvent EvFinTrace() End Sub Public Sub FinTrace() RaiseEvent EvFinTrace() End Sub Protected Overridable Sub InitialiserTracerFract() ' Utile pour initialiser les classes dérivées End Sub Protected Function bQuitter() As Boolean ' Traiter les messages (par ex. tracé d'un rectangle de sélection) Application.DoEvents() While Me.m_bPause Application.DoEvents() If Me.m_bQuitterTrace Then bQuitter = True : Exit Function End While If Me.m_bQuitterTrace Then bQuitter = True End Function Protected Overridable Sub TracerFract(iPas%) Dim penPixel As New Pen(Color.Black, 1) For iPaveY As Integer = 0 To m_cf.iPaveMaxY ' Pas possible avec Drawing.Graphics 'Parallel.For(0, m_cf.iPaveMaxY, Sub(iPaveY) m_cf.rYAbs = (iPaveY + 0.5D) * m_cf.rHautPaveAbs + m_cf.rCoordAbsYMin For iPaveX As Integer = 0 To m_cf.iPaveMaxX If bQuitter() Then Exit Sub m_cf.rXAbs = (iPaveX + 0.5D) * m_cf.rLargPaveAbs + m_cf.rCoordAbsXMin Dim bFrontiere As Boolean = False Dim iNbIterations% = iCompterIterations(m_cf.rXAbs, m_cf.rYAbs, iPaveX, iPaveY, iPas%, m_cf, bFrontiere) Dim bInterpoler As Boolean = Not m_prmPalette.bFrontiereUnie If bInterpoler AndAlso bFrontiere Then If iPas > 1 Then m_remplissage.Color = m_prm.coulInterpolee Else penPixel.Color = m_prm.coulInterpolee End If Else If iPas > 1 Then m_remplissage.Color = CouleurPalette(iNbIterations, bFrontiere) Else penPixel.Color = CouleurPalette(iNbIterations, bFrontiere) End If End If ' Si le pavé est de 1 pixel, un PixelSet (PSet) serait plus rapide ' qu'un Rectangle plein, mais PixelSet n'existe pas en VB .Net : ' il est probablement implémenté dans FillRectangle() If iPas > 1 Then m_gr.FillRectangle(m_remplissage, m_cf.iMargeX + iPaveX * iPas, m_cf.iMargeY + iPaveY * iPas, iPas, iPas) Else ' Pas de gain de temps constaté m_gr.DrawLine(penPixel, m_cf.iMargeX + iPaveX, m_cf.iMargeY + iPaveY, m_cf.iMargeX + iPaveX + 1, m_cf.iMargeY + iPaveY) End If If m_bQuitterTrace Then Exit Sub Next iPaveX If m_szTailleEcran.Height > 1 Then Dim iAvancement% = CInt(100 * iPaveY / m_cf.iPaveMaxY) RaiseEvent EvMajAvancement(iAvancement) End If RaiseEvent EvMajBmp() Next iPaveY End Sub Public Sub CalculerNbCouleurs() If m_prmPalette.bPaletteSysteme Then m_iNbCouleurs = m_prmPalette.iNbCouleurs ReDim m_aiCouleurs%(0) Else m_iNbCouleurs = iNbCouleursPalette \ m_prmPalette.iNbCyclesDegrade ReDim m_aiCouleurs%(iNbCouleursReservees + m_iNbCouleurs) End If End Sub Public Sub InitPaletteCalc() m_aiCouleurs(iCodePixelNonExamine) = kcCouleurPixelNonExamine ' KnownColor.White m_aiCouleurs(iCodePixelFrontiere) = kcCouleurPixelFrontiere ' KnownColor.LightGreen Dim iNumCouleur% = 0 Dim iNumCouleurZone% = -1 Dim iZonePalette% = 0 Dim iTailleZonePalette% = m_iNbCouleurs \ m_prmPalette.iNbCyclesDegrade If iTailleZonePalette = 0 Then iTailleZonePalette = 1 End If Dim iPas% = m_prmPalette.iNbCyclesDegrade Dim lst As List(Of Integer) = Nothing If m_prmPalette.bPaletteAleatoire Then lst = New List(Of Integer) Dim ht As New Dictionary(Of Integer, Integer) For i As Integer = 0 To iNbCouleursPalette - 1 Step iPas Dim colorValueR% = 0 Dim colorValueG% = 0 Dim colorValueB% = 0 If i >= 1020 Then colorValueR = i - 1020 + 1 colorValueG = colorValueR colorValueB = colorValueR ElseIf i >= 766 Then colorValueR = 255 + (766 - i) - 1 colorValueG = 0 colorValueB = 0 ElseIf i >= 511 Then colorValueR = i - 511 + 1 colorValueG = 255 - colorValueR ElseIf i >= 256 Then colorValueG = i - 255 colorValueB = 255 - colorValueG Else colorValueB = i End If Dim color00 As Color = Color.FromArgb(colorValueR, colorValueG, colorValueB) Dim iCouleur% = color00.ToArgb If m_prmPalette.bPaletteAleatoire Then lst.Add(iCouleur) Else iZonePalette = iNumCouleur Mod m_prmPalette.iNbCyclesDegrade If iZonePalette = 0 Then iNumCouleurZone += 1 Dim iIndice% = iNbCouleursReservees + iNumCouleurZone + iZonePalette * iTailleZonePalette 'Debug.WriteLine(iNumCouleur.ToString("000") & " : " & iIndice.ToString("000") & _ ' " -> " & iCouleur.ToString("000000000") & " R" & colorValueR.ToString("000") & _ ' " G" & colorValueG.ToString("000") & " B" & colorValueB.ToString("000")) m_aiCouleurs(iIndice) = iCouleur End If iNumCouleur += 1 Next i If m_prmPalette.bPaletteAleatoire Then Dim iIndice% = iNbCouleursReservees Do While lst.Count > 0 Dim iNumColMax% = lst.Count - 1 Dim iNumCol% = iRandomiser(0, iNumColMax) Dim iCouleur% = lst(iNumCol) lst.RemoveAt(iNumCol) m_aiCouleurs(iIndice) = iCouleur iIndice += 1 Loop Else ' Vérification de la répartition For iNbIterations As Integer = 0 To iNumCouleur - 1 Dim iCouleurFinale% = m_aiCouleurs(iNbIterations + iNbCouleursReservees) If Not ht.ContainsKey(iCouleurFinale) Then ht.Add(iCouleurFinale, iNbIterations) Else If iCouleurFinale = 0 Then Debug.WriteLine("Couleur vide ! " & iCouleurFinale & " : " & iNbIterations) 'If bDebug Then Stop End If Dim iNbIterations0% = ht(iCouleurFinale) If iNbIterations0 <> iNbIterations Then Debug.WriteLine("Collision palette ! " & iCouleurFinale & " : " & iNbIterations0 & "<>" & iNbIterations) 'If bDebug Then Stop End If End If Next End If 'Debug.WriteLine("Nombre final de couleurs : " & iNumCouleur) End Sub Public Function CouleurPalette(iNbIterations%, bFrontiere As Boolean) As Color ' Détermination de la couleur de la palette standard ' à partir du modulo iCouleurMax Dim couleur As Color Dim iIndiceCouleur% If iNbIterations = iCodePixelNonExamine Then iIndiceCouleur = iCodePixelNonExamine Dim iCouleurFinaleKC% = kcCouleurPixelNonExamine 'KnownColor.White Dim kc As KnownColor = CType(iCouleurFinaleKC, Drawing.KnownColor) couleur = Color.FromKnownColor(kc) ElseIf bFrontiere Then 'iNbIterations = iCodePixelFrontiere Then iIndiceCouleur = iCodePixelFrontiere Dim iCouleurFinaleKC% = kcCouleurPixelFrontiere 'KnownColor.LightGreen Dim kc As KnownColor = CType(iCouleurFinaleKC, Drawing.KnownColor) couleur = Color.FromKnownColor(kc) Else iIndiceCouleur = iNbCouleursReservees + (m_prmPalette.iPremCouleur + iNbIterations) Mod m_iNbCouleurs If Not m_prmPalette.bPaletteSysteme Then Dim iCouleurFinale0% = m_aiCouleurs(iIndiceCouleur) couleur = Color.FromArgb(iCouleurFinale0) Else Dim kc As KnownColor = CType(iIndiceCouleur, Drawing.KnownColor) couleur = Color.FromKnownColor(kc) End If End If Dim iCouleurFinale% = couleur.ToArgb 'Debug.WriteLine(iNbIterations & " -> " & iIndiceCouleur & " (" & iCouleurFinale & ")") ' Vérifier ssi le nombre d'itération est < au nombre de couleurs de la palette ' (sinon c'est normale d'avoir des colisions) 'Static hs As New HashSet(Of Integer) 'If Not hs.Contains(iNbIterations) Then ' hs.Add(iNbIterations) ' Debug.WriteLine(iNbIterations & " -> " & iIndiceCouleur & " (" & iCouleurFinale & ")") 'End If 'Static ht As New Dictionary(Of Integer, Integer) 'If Not ht.ContainsKey(iNbIterations) Then ' ht.Add(iNbIterations, iCouleurFinale) 'Else ' Dim iCouleurFinale0% = ht(iNbIterations) ' If iCouleurFinale0 <> iCouleurFinale Then ' Debug.WriteLine("Collision palette !") ' Stop ' End If 'End If Return couleur End Function Protected Function iCalculerCouleur%(iNbIter%, bFrontiere As Boolean) Dim iIndiceCoul1% Const bAfficherFontiere As Boolean = True If bFrontiere AndAlso Not bAfficherFontiere Then ' Si on n'affiche pas la frontière, alors on applique le modulo même sur la frontière ' Mais comme on augmente le nombre d'itération max. de façon à ce que ' le nombre d'itération max. - min. soit constant, du coup la couleur max. n'est pas stable ' Conclusion : mieux vaux afficher une couleur de fontrière fixe iIndiceCoul1 = iNbCouleursReservees + (iNbIter Mod m_iNbCouleurs) Return iIndiceCoul1 End If If bFrontiere Then iIndiceCoul1 = iCodePixelFrontiere Else iIndiceCoul1 = iNbCouleursReservees + (iNbIter Mod m_iNbCouleurs) End If Return iIndiceCoul1 End Function Protected Function InterpolateColors%(s1%, s2%, weigth%) Dim c1 As Color = Color.FromArgb(s1) Dim c2 As Color = Color.FromArgb(s2) Dim lRed0& = (CLng(c2.R) - CLng(c1.R)) * weigth Dim lGreen0& = (CLng(c2.G) - CLng(c1.G)) * weigth Dim lBlue0& = (CLng(c2.B) - CLng(c1.B)) * weigth Dim lRed& = CLng(c1.R) + (lRed0 >> 8) Dim lGreen& = CLng(c1.G) + (lGreen0 >> 8) Dim lBlue& = CLng(c1.B) + (lBlue0 >> 8) Dim red As Byte = CByte(lRed And &HFF) Dim green As Byte = CByte(lGreen And &HFF) Dim blue As Byte = CByte(lBlue And &HFF) Return Color.FromArgb(red, green, blue).ToArgb 'int InterpolateColors(int s1, int s2, int weigth){ ' Color c1 = Color.FromArgb(s1); Color c2 = Color.FromArgb(s2); ' byte red = (byte)(((int)c1.R + ((int)((c2.R - c1.R) * weigth) >> 8)) & 0xff); ' byte green = (byte)(((int)c1.G + ((int)((c2.G - c1.G) * weigth) >> 8)) & 0xff); ' byte blue = (byte)(((int)c1.B + ((int)((c2.B - c1.B) * weigth) >> 8)) & 0xff); ' return Color.FromArgb(red, green, blue).ToArgb(); } End Function Public Sub SelectionnerPoint(pt As Point) InitCoordFract(iPasMin, pt) Dim bFrontiere As Boolean = False iCompterIterations(m_cf.rXAbs, m_cf.rYAbs, pt.X, pt.Y, iPasMin, m_cf, bFrontiere) RaiseEvent EvDetailIterations(m_oDetailIter.aptLirePoint) End Sub Private Sub InitCoordFract(iPas%, pt As Point) InitCoordFract(m_cf, iPas) m_cf.rXAbs = (pt.X \ iPas) * m_cf.rLargPaveAbs + m_cf.rCoordAbsXMin m_cf.rYAbs = (pt.Y \ iPas) * m_cf.rHautPaveAbs + m_cf.rCoordAbsYMin End Sub Protected Sub InitCoordFract(ByRef cf As TCoordFract, iPas%) cf.iPaveMaxX = m_szTailleEcran.Width \ iPas - 1 cf.iPaveMaxY = m_szTailleEcran.Height \ iPas - 1 cf.iMargeX = (m_szTailleEcran.Width - (cf.iPaveMaxX + 1) * iPas) \ 2 cf.iMargeY = (m_szTailleEcran.Height - (cf.iPaveMaxY + 1) * iPas) \ 2 cf.rLargPaveAbs = (cf.rCoordAbsXMax - cf.rCoordAbsXMin) / (cf.iPaveMaxX + 1) cf.rHautPaveAbs = (cf.rCoordAbsYMax - cf.rCoordAbsYMin) / (cf.iPaveMaxY + 1) 'Debug.WriteLine("Pos.XYMinMax : " & cf.rCoordAbsXMin & ", " & cf.rCoordAbsXMax & ", " & _ ' cf.rCoordAbsYMin & ", " & cf.rCoordAbsYMax) End Sub Protected Function iCompterIterations%(rX As Decimal, rY As Decimal, iPaveX%, iPaveY%, iPas%, cf As TCoordFract, ByRef bFrontiere As Boolean) ' Nombre complexe Z = a + ib avec i*i = -1 ' Equation : Z -> Z^degré + C If m_bDecimal Then Return iCompterIterations_Decimal(rX, rY, iPaveX, iPaveY, iPas, cf, bFrontiere) End If bFrontiere = False Dim iNbIterations% = 0 Dim a, b, a2, b2, mem_a, mem_b As Double Dim rX1, rY1, r1, i1, r1pow2, i1pow2, rpow, rlastpow, rCount_f, rFactor As Double If m_prm.typeFract = TFractal.Mandelbrot Then m_prm.rRe = rX m_prm.rIm = rY a = 0D b = 0D Else ' Julia a = rX b = rY iNbIterations = 1 End If If m_bModeDetailIterations Then m_oDetailIter.Initialiser() Dim bJulia0 As Boolean = False If m_prm.typeFract = TFractal.Julia Then bJulia0 = True Select Case m_prm.iDegre Case 2 ' 2x plus rapide s'il y a 10000 itérations (mais sinon faible gain) If m_bAlgoRapide Then rX1 = m_prm.rXd * iPaveX * iPas + cf.rCoordAbsXMin rY1 = m_prm.rYd * iPaveY * iPas + cf.rCoordAbsYMin r1 = 0 i1 = 0 r1pow2 = 0 i1pow2 = 0 If bJulia0 Then a = m_prm.rRe b = m_prm.rIm r1 = rX1 i1 = rY1 r1pow2 = r1 * r1 i1pow2 = i1 * i1 End If rpow = 0 rlastpow = 0 Do While iNbIterations <= m_iNbIterationsMax AndAlso rpow < 4 r1pow2 = r1 * r1 i1pow2 = i1 * i1 If bJulia0 Then i1 = 2 * i1 * r1 + b r1 = r1pow2 - i1pow2 + a Else i1 = (2 * i1) * r1 + rY1 r1 = r1pow2 - i1pow2 + rX1 End If rlastpow = rpow rpow = r1pow2 + i1pow2 iNbIterations += 1 Loop If iNbIterations >= m_iNbIterationsMax Then bFrontiere = True Dim bInterpoler As Boolean = Not m_prmPalette.bFrontiereUnie If bInterpoler AndAlso bFrontiere Then rCount_f = iNbIterations - 1 + (4 - rlastpow) / (rpow - rlastpow) rFactor = (1D - (iNbIterations - rCount_f)) * 255 Dim iFactor% = 0 If rFactor >= Integer.MinValue AndAlso rFactor <= Integer.MaxValue Then iFactor = CInt(rFactor) Dim iCoul1% = iCalculerCouleur(iNbIterations - 1, bFrontiere:=False) Dim iCoul2% = iCalculerCouleur(iNbIterations, bFrontiere:=False) Dim iCoul% = InterpolateColors(iCoul1, iCoul2, iFactor) m_prm.coulInterpolee = Color.FromArgb(iCoul) End If Else Do If m_bModeDetailIterations Then _ m_oDetailIter.AjouterPointDetailIterations(a, b, m_cf) a2 = a * a b2 = b * b ' On sort du cercle unitaire If a2 + b2 > 4 Then Exit Do b = 2 * a * b + m_prm.rIm a = a2 - b2 + m_prm.rRe iNbIterations += 1 Loop While iNbIterations <= m_iNbIterationsMax End If Case 3 Do If m_bModeDetailIterations Then _ m_oDetailIter.AjouterPointDetailIterations(a, b, m_cf) a2 = a * a b2 = b * b If a2 + b2 > 4 Then Exit Do mem_a = a mem_b = b b = 2 * a * b a = a2 - b2 a2 = mem_a * a b2 = mem_b * b b = mem_a * b + mem_b * a + m_prm.rIm a = a2 - b2 + m_prm.rRe iNbIterations += 1 Loop While iNbIterations <= m_iNbIterationsMax Case 4 Do If m_bModeDetailIterations Then _ m_oDetailIter.AjouterPointDetailIterations(a, b, m_cf) a2 = a * a b2 = b * b If a2 + b2 > 4 Then Exit Do b = 2 * a * b a = a2 - b2 a2 = a * a b2 = b * b b = 2 * a * b + m_prm.rIm a = a2 - b2 + m_prm.rRe iNbIterations += 1 Loop While iNbIterations <= m_iNbIterationsMax Case 5 Do If m_bModeDetailIterations Then _ m_oDetailIter.AjouterPointDetailIterations(a, b, m_cf) a2 = a * a b2 = b * b If a2 + b2 > 4 Then Exit Do mem_a = a : mem_b = b b = 2 * a * b a = a2 - b2 a2 = a * a b2 = b * b b = 2 * a * b a = a2 - b2 a2 = mem_a * a b2 = mem_b * b b = mem_a * b + mem_b * a + m_prm.rIm a = a2 - b2 + m_prm.rRe iNbIterations += 1 Loop While iNbIterations <= m_iNbIterationsMax End Select If iNbIterations >= m_iNbIterationsMax Then bFrontiere = True If iNbIterations < m_iNbIterationsMin Then m_iNbIterationsMin = iNbIterations 'Debug.WriteLine("-> m_iNbIterationsMin = " & m_iNbIterationsMin) End If Return iNbIterations End Function Private Function iCompterIterations_Decimal%(rX As Decimal, rY As Decimal, iPaveX%, iPaveY%, iPas%, cf As TCoordFract, ByRef bFrontiere As Boolean) ' Nombre complexe Z = a + ib avec i*i = -1 ' Equation : Z -> Z^degré + C bFrontiere = False Dim iNbIterations% = 0 Dim a, b, a2, b2, mem_a, mem_b As Decimal Dim rX1, rY1, r1, i1, r1pow2, i1pow2, rpow, rlastpow, rCount_f, rFactor As Decimal If m_prm.typeFract = TFractal.Mandelbrot Then m_prm.rRe = rX m_prm.rIm = rY a = 0D b = 0D Else ' Julia a = rX b = rY iNbIterations = 1 End If If m_bModeDetailIterations Then m_oDetailIter.Initialiser() Select Case m_prm.iDegre Case 2 ' 2x plus rapide s'il y a 10000 itérations (mais sinon faible gain) If m_bAlgoRapide Then rX1 = m_prm.rXd * iPaveX * iPas + cf.rCoordAbsXMin rY1 = m_prm.rYd * iPaveY * iPas + cf.rCoordAbsYMin r1 = 0 i1 = 0 If m_prm.typeFract = TFractal.Julia Then a = m_prm.rRe b = m_prm.rIm r1 = rX1 i1 = rY1 End If r1pow2 = 0 i1pow2 = 0 rpow = 0 rlastpow = 0 Do While iNbIterations <= m_iNbIterationsMax AndAlso rpow < 4 r1pow2 = r1 * r1 i1pow2 = i1 * i1 i1 = (2 * i1) * r1 + rY1 + b r1 = r1pow2 - i1pow2 + rX1 + a rlastpow = rpow rpow = r1pow2 + i1pow2 iNbIterations += 1 Loop If iNbIterations >= m_iNbIterationsMax Then bFrontiere = True Dim bInterpoler As Boolean = Not m_prmPalette.bFrontiereUnie If bInterpoler AndAlso bFrontiere Then rCount_f = iNbIterations - 1 + (4 - rlastpow) / (rpow - rlastpow) rFactor = (1D - (iNbIterations - rCount_f)) * 255 Dim iFactor% = 0 If rFactor >= Integer.MinValue AndAlso rFactor <= Integer.MaxValue Then iFactor = CInt(rFactor) Dim iCoul1% = iCalculerCouleur(iNbIterations - 1, bFrontiere:=False) Dim iCoul2% = iCalculerCouleur(iNbIterations, bFrontiere:=False) Dim iCoul% = InterpolateColors(iCoul1, iCoul2, iFactor) m_prm.coulInterpolee = Color.FromArgb(iCoul) End If Else Do If m_bModeDetailIterations Then _ m_oDetailIter.AjouterPointDetailIterations(a, b, m_cf) a2 = a * a b2 = b * b ' On sort du cercle unitaire If a2 + b2 > 4 Then Exit Do b = 2 * a * b + m_prm.rIm a = a2 - b2 + m_prm.rRe iNbIterations += 1 Loop While iNbIterations <= m_iNbIterationsMax End If Case 3 Do If m_bModeDetailIterations Then _ m_oDetailIter.AjouterPointDetailIterations(a, b, m_cf) a2 = a * a b2 = b * b If a2 + b2 > 4 Then Exit Do mem_a = a mem_b = b b = 2 * a * b a = a2 - b2 a2 = mem_a * a b2 = mem_b * b b = mem_a * b + mem_b * a + m_prm.rIm a = a2 - b2 + m_prm.rRe iNbIterations += 1 Loop While iNbIterations <= m_iNbIterationsMax Case 4 Do If m_bModeDetailIterations Then _ m_oDetailIter.AjouterPointDetailIterations(a, b, m_cf) a2 = a * a b2 = b * b If a2 + b2 > 4 Then Exit Do b = 2 * a * b a = a2 - b2 a2 = a * a b2 = b * b b = 2 * a * b + m_prm.rIm a = a2 - b2 + m_prm.rRe iNbIterations += 1 Loop While iNbIterations <= m_iNbIterationsMax Case 5 Do If m_bModeDetailIterations Then _ m_oDetailIter.AjouterPointDetailIterations(a, b, m_cf) a2 = a * a b2 = b * b If a2 + b2 > 4 Then Exit Do mem_a = a : mem_b = b b = 2 * a * b a = a2 - b2 a2 = a * a b2 = b * b b = 2 * a * b a = a2 - b2 a2 = mem_a * a b2 = mem_b * b b = mem_a * b + mem_b * a + m_prm.rIm a = a2 - b2 + m_prm.rRe iNbIterations += 1 Loop While iNbIterations <= m_iNbIterationsMax End Select If iNbIterations >= m_iNbIterationsMax Then bFrontiere = True If iNbIterations < m_iNbIterationsMin Then m_iNbIterationsMin = iNbIterations Return iNbIterations End Function #End Region End Class clsFractQuadTreeR.vb ' Fichier ClsFractQuadTreeR.vb ' ---------------------------- Imports System.Text ' Pour StringBuilder Public Class ClsFractQuadTreeR : Inherits ClsFractRemplissage #Region "Configuration" Private Const bModeLent As Boolean = False Private Const iDelaisMSec% = 10 '50 Si mode lent ' QT : QuadTree Private Const iPasMaxQT% = 32 ' Pavé de 32x32 pixels Private Const iPasMinQT% = 1 Private Const bModeRemplissageQT As Boolean = False #End Region #Region "Déclarations" Public Shadows Event EvFinTrace() ' m_cfMax : coord. fract. avec des pavés de taille max. (iPasMaxQT) ' m_cfMin : coord. fract. avec des pavés de taille min. (iPasMinQT) Private m_cfMax, m_cfMin As TCoordFract ' Rapport entre les tailles de pavé Private Const iFact% = iPasMaxQT \ iPasMinQT Private Const iFactSur2% = iFact \ 2 Private Const iFactSur4% = iFact \ 4 Private m_iIndiceMaxPas% ' Tableau de piles correspondant à chaque taille de pavé Private m_aPiles() As ClsPile Protected m_remplissageCyan As New SolidBrush(couleurFondCyan) ' Shadows indique que l'on masque l'événement de la classe de base Public Shadows Event EvMajBmp() ' Définition de l'avancement du remplissage : ' on se base sur la proportion de pixels à examiner, ' proportion obtenue à la résolution précédente Public Shadows Event EvMajAvancement(iAvancement%) Private m_iNbPixels% ' Nombre de pixels examinés Private m_rTauxMaxSurfaceRemp! ' Taux max. de surface remplie ' Taux min. de surface remplie lorsque la résolution des images augmente Private m_rTauxMinSurfaceRempImages! ' Tableau pour mémoriser les codes des pixels analysés Private m_aiCodesPixelQT(,,) As Byte #End Region #Region "Tracé des images fractales avec le remplissage" Public Overrides Sub TracerFractDepart(bmpCache As Bitmap) MyBase.InitTracerFractDepart() TracerFractQuadTree() End Sub Private Sub TracerFractQuadTree() ' iNbIterationsMax dépend du nombre d'itérations min. précédant : ' cela évite de le définir trop élevé dès le début, alors que ' c'est seulement pour un zoom profond que l'on a besoin de ' beaucoup d'itérations m_iMemNbIterationsMin = m_iNbIterationsMin If Not m_bZoomMoins AndAlso m_iNbIterationsMin < iIntegerMax Then _ m_iNbIterationsMax = m_prm.iNbIterationsMaxDepart + m_iNbIterationsMin m_iNbIterationsMin = iIntegerMax m_gr.Clear(couleurFondCyan) RaiseEvent EvMajBmp() ' Recopier les coord. du zoom m_cfMax = m_cf ' D'abord voir combien il y a de gros carrés dans l'écran MyBase.InitCoordFract(m_cfMax, iPasMaxQT) m_cfMin = m_cfMax ' Recopier les marges + coord. du zoom ' Ensuite diviser les gros carrés en petits carrés m_cfMin.iPaveMaxX = m_cfMax.iPaveMaxX * iFact m_cfMin.iPaveMaxY = m_cfMax.iPaveMaxY * iFact m_cfMin.rLargPaveAbs = m_cfMax.rLargPaveAbs / iFact m_cfMin.rHautPaveAbs = m_cfMax.rHautPaveAbs / iFact ' Pour algo. rapide ' ----------------- Dim W As Decimal = m_cf.rCoordAbsXMax - m_cf.rCoordAbsXMin Dim H As Decimal = m_cf.rCoordAbsYMax - m_cf.rCoordAbsYMin Dim width% = m_szTailleEcran.Width Dim heigth% = m_szTailleEcran.Height Dim X2 As Decimal = (m_cf.rCoordAbsXMax + m_cf.rCoordAbsXMin) / 2 Dim Y2 As Decimal = (m_cf.rCoordAbsYMax + m_cf.rCoordAbsYMin) / 2 Dim xs As Decimal = X2 - (W / 2) Dim ys As Decimal = Y2 - (H / 2) m_prm.rXd = W / CDec(width) m_prm.rYd = H / CDec(heigth) ' ----------------- ' Pour cacher les gros pixels hors zone If m_bEffacerImg Then m_gr.Clear(couleurFondCyan) m_iIndiceMaxPas = CInt(Math.Log(iFact) / Math.Log(2)) ReDim m_aPiles(m_iIndiceMaxPas) Dim i% For i = 0 To m_iIndiceMaxPas m_aPiles(i) = New ClsPile() m_aPiles(i).Initialiser() Next i ' 05/08/2014 Même sans remplissage, on va l'utiliser, car bPtDejaTracé n'est plus utilisé 'ReDim m_aiCodesPixelQT(m_iIndiceMaxPas, m_cfMin.iPaveMaxX + 1, m_cfMin.iPaveMaxY + 1) ' Optimisation à faire : pas besoin de toute la largeur à chaque niveau ! ReDim m_aiCodesPixelQT(m_iIndiceMaxPas, m_cfMin.iPaveMaxX + iFact, m_cfMin.iPaveMaxY + iFact) If bModeRemplissageQT Then If Not bModeRemplissage() Then Exit Sub Else TracerFract() End If RaiseEvent EvMajBmp() RaiseEvent EvFinTrace() 'If Not m_bQuitterTrace Then Beep(600, 20) End Sub Private Function bModeRemplissage() As Boolean Dim iIndicePasAct% = 0 Dim iPaveX%, iPaveY% If bDebugRemp Then If Not bTracerQT(0, 0) Then Exit Function Return True End If iPaveY = 0 For iPaveX = 0 To m_cfMin.iPaveMaxX - iFact Step iFact If m_aiCodesPixelQT(iIndicePasAct, iPaveX, iPaveY) = iCodePixelNonExamine Then _ If Not bTracerQT(iPaveX, iPaveY) Then Exit Function If bQuitter() Then Exit Function Next iPaveX iPaveX = m_cfMin.iPaveMaxX For iPaveY = 0 To m_cfMin.iPaveMaxY - iFact Step iFact If m_aiCodesPixelQT(iIndicePasAct, iPaveX, iPaveY) = iCodePixelNonExamine Then _ If Not bTracerQT(iPaveX, iPaveY) Then Exit Function If bQuitter() Then Exit Function Next iPaveY iPaveY = m_cfMin.iPaveMaxY For iPaveX = m_cfMin.iPaveMaxX To 0 Step -iFact If m_aiCodesPixelQT(iIndicePasAct, iPaveX, iPaveY) = iCodePixelNonExamine Then _ If Not bTracerQT(iPaveX, iPaveY) Then Exit Function If bQuitter() Then Exit Function Next iPaveX iPaveX = 0 For iPaveY = m_cfMin.iPaveMaxY - iFact To iFact Step -iFact If m_aiCodesPixelQT(iIndicePasAct, iPaveX, iPaveY) = iCodePixelNonExamine Then _ If Not bTracerQT(iPaveX, iPaveY) Then Exit Function If bQuitter() Then Exit Function Next iPaveY Return True End Function Private Shadows Sub TracerFract() m_rTauxMaxSurfaceRemp = 0 m_iNbPixels = 0 Dim iPaveX%, iPaveY% For iPaveX = 0 To m_cfMax.iPaveMaxX For iPaveY = 0 To m_cfMax.iPaveMaxY If Not bTracerQT(iPaveX * iFact, iPaveY * iFact) Then Exit Sub If bQuitter() Then Exit Sub Next iPaveY : Next iPaveX If m_rTauxMaxSurfaceRemp < m_rTauxMinSurfaceRempImages Then _ m_rTauxMinSurfaceRempImages = m_rTauxMaxSurfaceRemp RaiseEvent EvMajAvancement(100) End Sub Private Function bTracerQT(iPaveX%, iPaveY%) As Boolean If m_bQuitterTrace Then Exit Function Dim bRestePixel(m_iIndiceMaxPas) As Boolean Dim pt As PointPile Dim iPasSuivant%, iTaillePave%, iTaillePaveSuiteUPM%, iTaillePaveUPM% Dim rDec, rDec2 As Decimal Dim iPasAct% ' IndicePas va de 0 (résolution actuelle : correspond à des pavés iPasMaxQT) ' jusqu'au niveau de profondeur m_iIndiceMaxPas ' (correspond à des pavés iPasMinQT) Dim iIndicePasAct% = 0 CalculerPasSuivant(iIndicePasAct, iPasAct, iPasSuivant, iTaillePave, rDec, rDec2, iTaillePaveSuiteUPM, iTaillePaveUPM) 'Debug.WriteLine("iIndicePasAct=" & iIndicePasAct) ' On peut initialiser la pile à chaque remplissage, on est quand même sûr ' que l'on oubliera aucun pixels (car le remplissage est redondant), ' et la taille de la pile sera plus faible 'm_aPiles(iIndicePasAct).Initialiser() ' 05/08/2014 If Not m_aPiles(iIndicePasAct).bEmpiler(iPaveX, iPaveY) Then GoTo Echec 'Debug.WriteLine( _ ' "iIndicePasAct=" & iIndicePasAct & ", iPasAct=" & iPasAct & _ ' ", iPasSuivant=" & iPasSuivant & ", iTaillePave=" & iTaillePave & _ ' ", rDec=" & rDec & ", rDec2=" & rDec2 & _ ' ", iTaillePaveSuiteUPM=" & iTaillePaveSuiteUPM) Do If m_aPiles(iIndicePasAct).bPileVide Then GoTo ParcourirPile pt = m_aPiles(iIndicePasAct).ptDepilerPtPile iPaveX = pt.X iPaveY = pt.Y If bDebugQuadGr2 And iPasAct > 4 And bModeLent Then 'm_remplissage.Color = Color.Turquoise 'm_gr.FillRectangle(m_remplissage, _ ' m_cfMin.iMargeX + iPaveX * iPasMinQT, _ ' m_cfMin.iMargeY + iPaveY * iPasMinQT, iPasAct, iPasAct) Dim penPixel As New Pen(Color.White, 2) 'penPixel.Color = Color.FromKnownColor(kcCouleurPalette(iNbIterations)) 'm_gr.DrawLine(penPixel, _ ' m_cfMin.iMargeX, m_cfMin.iMargeY, _ ' m_cfMin.iMargeX + iPaveX * iPasMinQT, m_cfMin.iMargeY + iPaveY * iPasMinQT) m_gr.DrawLine(penPixel, m_cfMin.iMargeX + iPaveX * iPasMinQT, m_cfMin.iMargeY + iPaveY * iPasMinQT, m_cfMin.iMargeX + iPaveX * iPasMinQT + iPasAct, m_cfMin.iMargeY + iPaveY * iPasMinQT + iPasAct) RaiseEvent EvMajBmp() Application.DoEvents() If iDelaisMSec > 0 Then Threading.Thread.Sleep(iDelaisMSec) End If If m_aiCodesPixelQT(iIndicePasAct, iPaveX, iPaveY) <> iCodePixelNonExamine Then 'Debug.WriteLine(iPaveX & ", " & iPaveY & " : " & m_aiCodesPixelQT(iIndicePasAct, iPaveX, iPaveY)) GoTo ParcourirPile End If bRestePixel(iIndicePasAct) = True m_iNbPixels += 1 Dim rPaveXCentre As Decimal = iPaveX + rDec Dim rPaveYCentre As Decimal = iPaveY + rDec m_cfMin.rXAbs = rPaveXCentre * m_cfMin.rLargPaveAbs + m_cfMin.rCoordAbsXMin m_cfMin.rYAbs = rPaveYCentre * m_cfMin.rHautPaveAbs + m_cfMin.rCoordAbsYMin Dim bFrontiere As Boolean = False Dim iNbIterations% = MyBase.iCompterIterations(m_cfMin.rXAbs, m_cfMin.rYAbs, iPaveX, iPaveY, iPasMinQT, m_cfMin, bFrontiere) ' iPasAct ' 03/08/2014 Dim iCodePixel As Byte If Not bFrontiere Then 'iNbIterations > iCodePixelFrontiere Then iCodePixel = iCodePixelDessin Else iCodePixel = iCodePixelFrontiere End If 'If iPaveX = 8 AndAlso iPaveY = 0 AndAlso iIndicePasAct = 0 AndAlso iCodePixel = 2 Then Stop m_aiCodesPixelQT(iIndicePasAct, iPaveX, iPaveY) = iCodePixel If bFrontiere AndAlso Not bAfficherPixelsFrontiereModeRemplissage Then GoTo ParcourirPile End If If bDebugQuadGr And iPasAct > 4 And bModeLent Then m_remplissage.Color = Color.Yellow m_gr.FillRectangle(m_remplissage, m_cfMin.iMargeX + iPaveX * iPasMinQT, m_cfMin.iMargeY + iPaveY * iPasMinQT, iPasAct, iPasAct) RaiseEvent EvMajBmp() Application.DoEvents() If iDelaisMSec > 0 Then Threading.Thread.Sleep(iDelaisMSec) End If Dim bInterpoler As Boolean = Not m_prmPalette.bFrontiereUnie If Not m_bAlgoRapide Then bInterpoler = False ' Ne marche qu'avec l'algo. rapide If bInterpoler AndAlso bFrontiere Then m_remplissage.Color = m_prm.coulInterpolee Else m_remplissage.Color = CouleurPalette(iNbIterations, bFrontiere) End If m_gr.FillRectangle(m_remplissage, m_cfMin.iMargeX + iPaveX * iPasMinQT, m_cfMin.iMargeY + iPaveY * iPasMinQT, iPasAct, iPasAct) If bDebugQuadGr And iPasAct > 4 Then ' Contour du pavé courant m_gr.DrawRectangle(Pens.Yellow, m_cfMin.iMargeX + iPaveX * iPasMinQT, m_cfMin.iMargeY + iPaveY * iPasMinQT, iPasAct, iPasAct) ' Rectangle de 2 pixels au centre du pavé courant Dim iLargPixel% = 2 Dim iPosG% = iLargPixel \ 2 m_gr.FillRectangle(Brushes.Tomato, m_cfMin.iMargeX + rPaveXCentre * iPasMinQT - iPosG, m_cfMin.iMargeY + rPaveYCentre * iPasMinQT - iPosG, iLargPixel, iLargPixel) End If If bModeLent Then RaiseEvent EvMajBmp() Application.DoEvents() If iDelaisMSec > 0 Then Threading.Thread.Sleep(iDelaisMSec) End If ' Coeur de l'algorithme de QuadTree ' Réduire le pas jusqu'a minPas If iIndicePasAct < m_iIndiceMaxPas Then Const bVerifierCentreCoins As Boolean = False ' False Const bVerifierMilieux As Boolean = False ' False ' Les coins suffisent Const bVerifierCoins As Boolean = True ' True Const bVerifierMilieuxBords As Boolean = False ' False Dim rPaveXCentreCoinG As Decimal = iPaveX + rDec - rDec2 Dim rPaveYCentreCoinH As Decimal = iPaveY + rDec - rDec2 Dim rPaveXCentreCoinD As Decimal = iPaveX + rDec + rDec2 Dim rPaveYCentreCoinB As Decimal = iPaveY + rDec + rDec2 Dim rPaveXBordDroite As Decimal = iPaveX + rDec + rDec Dim rPaveYBordBas As Decimal = iPaveY + rDec + rDec If bVerifierCentreCoins Then ' Centre du coin GH Gauche Haut If bApprofondir(rPaveXCentreCoinG, rPaveYCentreCoinH, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf ' Centre du coin DB Droite Bas If bApprofondir(rPaveXCentreCoinD, rPaveYCentreCoinB, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf ' Centre du coin GB Gauche Bas If bApprofondir(rPaveXCentreCoinG, rPaveYCentreCoinB, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf ' Centre du coin DH Droite Haut If bApprofondir(rPaveXCentreCoinD, rPaveYCentreCoinH, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf End If If bVerifierMilieux Then ' Milieu Haut If bApprofondir(rPaveXCentre, rPaveYCentreCoinH, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf ' Milieu Droite If bApprofondir(rPaveXCentreCoinD, rPaveYCentre, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf ' Milieu Bas If bApprofondir(rPaveXCentre, rPaveYCentreCoinB, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf ' Milieu Gauche If bApprofondir(rPaveXCentreCoinG, rPaveYCentre, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf End If If bVerifierCoins Then ' Coin HG If bApprofondir(iPaveX, iPaveY, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf ' Coin HD If bApprofondir(rPaveXBordDroite, rPaveYBordBas, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf ' Coin HD If bApprofondir(rPaveXBordDroite, iPaveY, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf ' Coin BG If bApprofondir(iPaveX, rPaveYBordBas, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf End If If bVerifierMilieuxBords Then ' Milieu bord Haut If bApprofondir(rPaveXCentre, iPaveY, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf ' Milieu bord Droit If bApprofondir(rPaveXBordDroite, rPaveYCentre, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf ' Milieu bord Bas If bApprofondir(rPaveXCentre, rPaveYBordBas, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf ' Milieu bord Gauche If bApprofondir(iPaveX, rPaveYCentre, iNbIterations, iPasAct, iPaveX, iPaveY) Then GoTo EmpilerCarresInf End If If bDebugQuadGr AndAlso iIndicePasAct = 0 Then If bModeLent Then RaiseEvent EvMajBmp() Application.DoEvents() If iDelaisMSec > 0 Then Threading.Thread.Sleep(iDelaisMSec) End If 'Debug.WriteLine("!") End If GoTo Remplissage EmpilerCarresInf: ' 25/08/2009 Ne pas empiler si iTaillePaveSuiteUPM=0 car bug précision ? If iTaillePaveSuiteUPM > 0 Then 'Debug.WriteLine( _ ' "iIndicePasAct=" & iIndicePasAct & ", iPasAct=" & iPasAct & _ ' ", iPasSuivant=" & iPasSuivant & ", iTaillePave=" & iTaillePave & _ ' ", rDec=" & rDec & ", rDec2=" & rDec2 & _ ' ", iTaillePaveSuiteUPM=" & iTaillePaveSuiteUPM) 'If iTaillePaveSuiteUPM = 1 Then ' Debug.WriteLine("!") 'End If If m_aiCodesPixelQT(iIndicePasAct + 1, iPaveX, iPaveY) = iCodePixelNonExamine Then If Not m_aPiles(iIndicePasAct + 1).bEmpiler(iPaveX, iPaveY) Then GoTo Echec End If If m_aiCodesPixelQT(iIndicePasAct + 1, iPaveX + iTaillePaveSuiteUPM, iPaveY) = iCodePixelNonExamine Then If Not m_aPiles(iIndicePasAct + 1).bEmpiler( iPaveX + iTaillePaveSuiteUPM, iPaveY) Then GoTo Echec End If If m_aiCodesPixelQT(iIndicePasAct + 1, iPaveX + iTaillePaveSuiteUPM, iPaveY + iTaillePaveSuiteUPM) = iCodePixelNonExamine Then If Not m_aPiles(iIndicePasAct + 1).bEmpiler( iPaveX + iTaillePaveSuiteUPM, iPaveY + iTaillePaveSuiteUPM) Then GoTo Echec End If If m_aiCodesPixelQT(iIndicePasAct + 1, iPaveX, iPaveY + iTaillePaveSuiteUPM) = iCodePixelNonExamine Then If Not m_aPiles(iIndicePasAct + 1).bEmpiler( iPaveX, iPaveY + iTaillePaveSuiteUPM) Then GoTo Echec End If End If End If Remplissage: If bModeRemplissageQT AndAlso (Not bFrontiere OrElse bInterpoler) Then ' Coeur de l'algorithme de remplissage If iPaveY >= iTaillePaveUPM AndAlso iPaveX <= m_cfMin.iPaveMaxX AndAlso iPaveY <= m_cfMin.iPaveMaxY AndAlso m_aiCodesPixelQT(iIndicePasAct, iPaveX, iPaveY - iTaillePaveUPM) = iCodePixelNonExamine Then If Not m_aPiles(iIndicePasAct).bEmpiler(iPaveX, iPaveY - iTaillePaveUPM) Then GoTo Echec End If If iPaveX >= iTaillePaveUPM AndAlso iPaveX <= m_cfMin.iPaveMaxX AndAlso iPaveY <= m_cfMin.iPaveMaxY AndAlso m_aiCodesPixelQT(iIndicePasAct, iPaveX - iTaillePaveUPM, iPaveY) = iCodePixelNonExamine Then _ If Not m_aPiles(iIndicePasAct).bEmpiler(iPaveX - iTaillePaveUPM, iPaveY) Then GoTo Echec If iPaveY <= m_cfMin.iPaveMaxY - iTaillePaveUPM AndAlso iPaveX <= m_cfMin.iPaveMaxX AndAlso m_aiCodesPixelQT(iIndicePasAct, iPaveX, iPaveY + iTaillePaveUPM) = iCodePixelNonExamine Then If Not m_aPiles(iIndicePasAct).bEmpiler(iPaveX, iPaveY + iTaillePaveUPM) Then GoTo Echec End If If iPaveX <= m_cfMin.iPaveMaxX - iTaillePaveUPM AndAlso iPaveY <= m_cfMin.iPaveMaxY AndAlso m_aiCodesPixelQT(iIndicePasAct, iPaveX + iTaillePaveUPM, iPaveY) = iCodePixelNonExamine Then _ If Not m_aPiles(iIndicePasAct).bEmpiler(iPaveX + iTaillePaveUPM, iPaveY) Then GoTo Echec End If ParcourirPile: ' Si bParcourirPile alors on reboucle sur la pile Dim bBouclePile As Boolean If bClassePilePerso Then bBouclePile = m_aPiles(iIndicePasAct).bParcourirPile Else bBouclePile = m_aPiles(iIndicePasAct).bPileVide End If If bBouclePile Then 'Debug.WriteLine("Fin de pile") ' Dans ce cas, s'il ne reste plus de pixel, alors on passe ' à la profondeur supérieure If Not bRestePixel(iIndicePasAct) Then iIndicePasAct += 1 If iIndicePasAct > m_iIndiceMaxPas Then Exit Do 'Debug.WriteLine("Profondeur : " & iIndicePasAct) CalculerPasSuivant(iIndicePasAct, iPasAct, iPasSuivant, iTaillePave, rDec, rDec2, iTaillePaveSuiteUPM, iTaillePaveUPM) 'Debug.WriteLine( _ ' "iIndicePasAct=" & iIndicePasAct & ", iPasAct=" & iPasAct & _ ' ", iPasSuivant=" & iPasSuivant & ", iTaillePave=" & iTaillePave & _ ' ", rDec=" & rDec & ", rDec2=" & rDec2 & _ ' ", iTaillePaveSuiteUPM=" & iTaillePaveSuiteUPM) End If bRestePixel(iIndicePasAct) = False RaiseEvent EvMajBmp() If m_rTauxMinSurfaceRempImages > 0 Then Dim rTauxSurfaceRemp! = CSng(m_iNbPixels / ((m_cfMin.iPaveMaxX + 1) * (m_cfMin.iPaveMaxY + 1))) Dim iAv% = CInt(100 * rTauxSurfaceRemp / m_rTauxMinSurfaceRempImages) RaiseEvent EvMajAvancement(iAv) End If Else ' Rafraichir l'écran à chaque itération : optimiser ? ToDo If m_aPiles(iIndicePasAct).bMajBmp() Then RaiseEvent EvMajBmp() End If If bQuitter() Then Exit Function Loop While Not m_bQuitterTrace Dim rTauxSurfaceRempFin! = CSng(m_iNbPixels / ((m_cfMin.iPaveMaxX + 1) * (m_cfMin.iPaveMaxY + 1))) If rTauxSurfaceRempFin > m_rTauxMaxSurfaceRemp Then _ m_rTauxMaxSurfaceRemp = rTauxSurfaceRempFin If m_bQuitterTrace Then Return False Return True Echec: Return False End Function Private Function bApprofondir(rPaveX As Decimal, rPaveY As Decimal, iNbIterations%, iPasAct%, iPaveX%, iPaveY%) As Boolean If bDebugQuadGr AndAlso iPasAct > 8 Then Dim iLargPixel% = 4 '3 Dim iPosG% = iLargPixel \ 2 m_gr.FillRectangle(Brushes.Yellow, m_cfMin.iMargeX + rPaveX * iPasMinQT - iPosG, m_cfMin.iMargeY + rPaveY * iPasMinQT - iPosG, iLargPixel, iLargPixel) 'If bModeLent Then ' RaiseEvent EvMajBmp() ' Application.DoEvents() ' If iDelaisMSec > 0 Then Threading.Thread.Sleep(iDelaisMSec) 'End If End If m_cfMin.rXAbs = rPaveX * m_cfMin.rLargPaveAbs + m_cfMin.rCoordAbsXMin m_cfMin.rYAbs = rPaveY * m_cfMin.rHautPaveAbs + m_cfMin.rCoordAbsYMin Dim bFrontiere As Boolean = False Dim iNbIter% = MyBase.iCompterIterations(m_cfMin.rXAbs, m_cfMin.rYAbs, iPaveX, iPaveY, iPasAct, m_cfMin, bFrontiere) If iNbIter <> iNbIterations Then Return True Return False End Function Private Sub CalculerPasSuivant(iIndicePasAct%, ByRef iPasAct%, ByRef iPasSuivant%, ByRef iTaillePave%, ByRef rDec As Decimal, ByRef rDec2 As Decimal, ByRef iTaillePaveSuiteUPM%, ByRef iTaillePaveUPM%) ' Le quadrillage se base sur le pas minimal (les pas supérieurs sont ' des multiples du pas de base) iPasAct = iPasMaxQT iTaillePaveUPM = iPasMaxQT \ iPasMinQT ' Calcul du centre du pavé actuel, unité = taille pavé min. If iPasMaxQT = iPasMinQT Then ' Si le pas max. = min. alors le centre est la moitié d'un pavé min. rDec = 0.5D rDec2 = 0 ' 20/07/2014 Il n'y a pas de pavé plus petit iPasSuivant = 0 ' 20/07/2014 Il n'y a pas de pavé plus petit ' Taille pavé suite dans l'unité du pavé min. (UPM) iTaillePaveSuiteUPM = 0 'iPasMinQT Else ' Sinon le centre est par défaut la moitié d'un pavé max. rDec = CDec(iPasMaxQT / iPasMinQT) / 2D rDec2 = rDec / 2D ' 20/07/2014 iTaillePaveSuiteUPM = (iPasMaxQT \ iPasMinQT) \ 2 iPasSuivant = iPasAct \ 2 ' Si 0 alors ne pas empiler End If Dim i% = iIndicePasAct While i > 0 iPasAct \= 2 iPasSuivant \= 2 ' Calcul du centre du pavé actuel If iPasSuivant = 0 Then rDec = 0.5D iTaillePaveSuiteUPM = 0 Else ' Sinon le centre est par défaut la moitié d'un pavé max. rDec = CDec(iPasAct / iPasMinQT) / 2D iTaillePaveSuiteUPM = (iPasAct \ iPasMinQT) \ 2 End If rDec2 = rDec / 2D i -= 1 End While iTaillePave = iPasAct 'Debug.WriteLine( _ ' "iIndicePasAct=" & iIndicePasAct & ", iPasAct=" & iPasAct & _ ' ", iPasSuivant=" & iPasSuivant & ", iTaillePave=" & iTaillePave & _ ' ", rDec=" & rDec & ", rDec2=" & rDec2 & _ ' ", iTaillePaveSuiteUPM=" & iTaillePaveSuiteUPM) End Sub #End Region End Class clsFractRapide.vb ' Classe rapide pour les fractales de degré 2 ' - Parallélisation du code ' - Tracé dans un tableau directement affiché en bitmap ' - Algorithme rapide (limité au dégré 2, et ' incorrect pour Julia : décalage du point de départ) ' D'après The beauty of fractals - A simple fractal rendering program done in C# ' https://www.codeproject.com/Articles/38514/The-beauty-of-fractals-A-simple-fractal-rendering Imports System.Drawing.Imaging Imports System.Runtime.InteropServices Imports System.Threading.Tasks ' Parallel.For Public Class clsFractRapide : Inherits clsFract #Region "Déclarations" ' Shadows indique que l'on masque l'événement de la classe de base Public Shadows Event EvMajBmp() ' Définition de l'avancement du remplissage : ' on se base sur la proportion de pixels à examiner, ' proportion obtenue à la résolution précédente Public Shadows Event EvMajAvancement(iAvancement%) Protected Shadows Const bAlgoRapide As Boolean = True Private m_palette%() = Nothing #End Region #Region "Tracé des images fractales" Public Overrides Sub InitConfig() MyBase.InitConfig() m_bEffacerImgDef = False End Sub Public Overrides Sub InitPalette() MyBase.InitPalette() InitPalette0(m_palette) End Sub Private Sub InitPalette0(ByRef colors0%()) Dim i As Integer Dim iMax% = m_iNbCouleurs + iNbCouleursReservees - 1 ReDim colors0(iMax) For i = 0 To iMax Dim color0 As Color = CouleurPalette(i, bFrontiere:=False) colors0(i) = color0.ToArgb Next i End Sub Protected Overrides Sub TracerFract(iPas%) ' Le 64 bits est 2x plus rapide que le 32 bits ! ' (mais pas de vidéo possible à cause de l'API vidéo en 32 bits) ' Le Single n'est pas plus rapide que le Double ' (et même un peu plus lent, surtout en 64 bits !) ' Le Décimal est très lent (20x plus lent) ' Programmation générique : pas simple : ' http://stackoverflow.com/questions/1267902/generics-where-t-is-a-number ' http://www.codeproject.com/Articles/8531/Using-generics-for-calculations ' http://tomasp.net/blog/fsharp-generic-numeric.aspx/ If m_bDecimal Then PartialRender_Decimal() Else 'PartialRender_Single() inutile PartialRender_Double() End If End Sub Sub PartialRender_Double() ' FracMaster ' https://www.codeproject.com/Articles/38514/The-beauty-of-fractals-A-simple-fractal-rendering Dim W, H, X2, Y2, xs, ys, xd, yd As Double W = m_cf.rCoordAbsXMax - m_cf.rCoordAbsXMin H = m_cf.rCoordAbsYMax - m_cf.rCoordAbsYMin ' Ne marche pas : on n'obtient pas exactement le même point de zoom ' (il faudrait commencer en décimal, mais 20x + lent) 'If W < rPaveMin OrElse H < rPaveMin Then ' PartialRender_Decimal() ' Exit Sub 'End If 'Debug.WriteLine("Nb iter.= " & m_iMemNbIterationsMin & " -> " & m_iNbIterationsMax & _ ' ", " & W & ", " & H) Dim width% = m_bmpCache.Width Dim heigth% = m_bmpCache.Height Dim pdate As BitmapData = Me.m_bmpCache.LockBits(New Rectangle(0, 0, width, heigth), ImageLockMode.ReadWrite, PixelFormat.Format32bppPArgb) Dim pscan0 As IntPtr = pdate.Scan0 'Dim iTaille% = width * heigth Dim dst%(width * heigth) 'If dst.Length - 1 <> iTaille Then ' Debug.WriteLine("!") 'End If Dim iTaillePal% = m_palette.Length ' Test Decimal : 20x + lent que Double ! X2 = (m_cf.rCoordAbsXMax + m_cf.rCoordAbsXMin) / 2 Y2 = (m_cf.rCoordAbsYMax + m_cf.rCoordAbsYMin) / 2 xs = X2 - (W / 2) ys = Y2 - (H / 2) xd = W / CDbl(width) yd = H / CDbl(heigth) Dim bMEtJ As Boolean = False Dim bJulia0 As Boolean = False If m_prm.typeFract = TFractal.Julia Then bJulia0 = True If m_prm.typeFract = TFractal.MandelbrotEtJulia Then bMEtJ = True 'For y As Integer = 0 To heigth - 1 Parallel.For(0, heigth - 1, Sub(y) Dim y1 As Double = ys + yd * y Dim x1, r1, i1, r1pow2, i1pow2, rpow, rlastpow, rCount_f, rFactor, a, b As Double Dim idx% = y * width x1 = xs For x As Integer = 0 To width - 1 r1 = 0 i1 = 0 a = 0 b = 0 r1pow2 = 0 i1pow2 = 0 If bJulia0 OrElse bMEtJ Then a = m_prm.rRe b = m_prm.rIm r1 = x1 i1 = y1 r1pow2 = r1 * r1 i1pow2 = i1 * i1 End If rpow = 0 rlastpow = 0 Dim iNbIter% = 0 Do While iNbIter < m_iNbIterationsMax AndAlso rpow < 4 r1pow2 = r1 * r1 i1pow2 = i1 * i1 If bJulia0 Then i1 = 2 * i1 * r1 + b r1 = r1pow2 - i1pow2 + a ElseIf bMEtJ Then i1 = (2 * i1) * r1 + y1 + b r1 = r1pow2 - i1pow2 + x1 + a Else i1 = (2 * i1) * r1 + y1 r1 = r1pow2 - i1pow2 + x1 End If rlastpow = rpow rpow = r1pow2 + i1pow2 iNbIter += 1 Loop Dim bFrontiere As Boolean = False If iNbIter >= m_iNbIterationsMax Then bFrontiere = True 'If rpow >= 4 Then Dans ce cas on a quitté la boucle sans atteindre la frontière ' Noter le nombre min. d'itérations pour déterminer le max. If iNbIter < m_iNbIterationsMin Then m_iNbIterationsMin = iNbIter Dim bInterpoler As Boolean = Not m_prmPalette.bFrontiereUnie If bInterpoler AndAlso bFrontiere Then rCount_f = iNbIter - 1 + (4 - rlastpow) / (rpow - rlastpow) rFactor = (1.0# - iNbIter + rCount_f) * 255 Dim iFactor% = 0 If rFactor >= Integer.MinValue AndAlso rFactor <= Integer.MaxValue Then iFactor = CInt(rFactor) Dim iCoul1% = iCalculerCouleur(iNbIter - 1, bFrontiere:=False) Dim iCoul2% = iCalculerCouleur(iNbIter, bFrontiere:=False) dst(idx) = InterpolateColors(iCoul1, iCoul2, iFactor) idx += 1 'Dim factor As Integer = CInt(((1.0 - (iter - count_f)) * 255)) 'dst(idx++) = Utils.InterpolateColors(Palette((iter - 1)), Palette(iter), factor) Else 'iNbIter = (iNbIter Mod Palette.Length) 'dst(idx) = Palette(iNbIter) Dim iIndiceCoul% = iCalculerCouleur(iNbIter, bFrontiere) dst(idx) = m_palette(iIndiceCoul) idx += 1 End If x1 += xd Next x 'y1 += yd End Sub) 'Next y ' Filtrage bilinéaire : appliquer un flou calculé en 2D pour éviter la pixellisation ' https://fr.wikipedia.org/wiki/Filtrage_bilinéaire ' Le filtrage bilinéaire est un algorithme utilisé en infographie permettant de calculer des ' pixels intermédiaires entre les pixels d'une image ou d'une texture que l'on change de taille. ' C'est un des procédés les plus utilisés depuis la fin des années 1990 par les cartes ' accélératrices 3D pour éviter l'effet de crènelage apparaissant dans le cas d'un filtrage linéaire. ' Ce filtrage utilise une interpolation bilinéaire qui, contrairement à une interpolation linéaire ' qui se contente d'interpoler en 1D (sur les lignes par exemple), l'interpolation est faite ' en 2D (lignes, colonnes). Ceci résulte en un effet de flou, bien plus agréable à l'œil que ' les carrés ou rectangles visibles habituellement sur une image agrandie. If m_prmPalette.bLisser Then RaiseEvent EvMajAvancement(80) Dim filteredColorTable As Integer() = New Integer(width * heigth - 1) {} Dim idxs11% = 0 Dim idxs12% = 0 Dim idxs21% = 0 Dim idxs22% = 0 For y As Integer = 0 To (heigth - 1) - 1 idxs11 = y * width idxs12 = idxs11 + 1 idxs21 = idxs11 + width idxs22 = idxs21 + 1 For x As Integer = 0 To (width - 1) - 1 Dim colf1% = InterpolateColors(dst(idxs11), dst(idxs12), &H7F) Dim colf2% = InterpolateColors(dst(idxs21), dst(idxs22), &H7F) filteredColorTable(idxs11) = InterpolateColors(colf1, colf2, &H80) idxs11 += 1 idxs12 += 1 idxs21 += 1 idxs22 += 1 Next Next dst = filteredColorTable End If RaiseEvent EvMajAvancement(90) Marshal.Copy(dst, 0, pscan0, dst.Length - 1) Me.m_bmpCache.UnlockBits(pdate) RaiseEvent EvMajBmp() RaiseEvent EvMajAvancement(100) End Sub Sub PartialRender_Decimal() ' FracMaster ' https://www.codeproject.com/Articles/38514/The-beauty-of-fractals-A-simple-fractal-rendering Dim W, H, X2, Y2, xs, ys, xd, yd As Decimal W = m_cf.rCoordAbsXMax - m_cf.rCoordAbsXMin H = m_cf.rCoordAbsYMax - m_cf.rCoordAbsYMin ' Ne marche pas : on n'obtient pas exactement le même point de zoom ' (il faudrait commencer en décimal, mais 20x + lent) 'If W < rPaveMin OrElse H < rPaveMin Then ' PartialRender_Decimal() ' Exit Sub 'End If 'Debug.WriteLine("Nb iter.= " & m_iMemNbIterationsMin & " -> " & m_iNbIterationsMax & _ ' ", " & W & ", " & H) Dim width% = m_bmpCache.Width Dim heigth% = m_bmpCache.Height Dim pdate As BitmapData = Me.m_bmpCache.LockBits(New Rectangle(0, 0, width, heigth), ImageLockMode.ReadWrite, PixelFormat.Format32bppPArgb) Dim pscan0 As IntPtr = pdate.Scan0 Dim dst%(width * heigth) Dim iTaillePal% = m_palette.Length ' Test Decimal : 20x + lent que Double ! X2 = (m_cf.rCoordAbsXMax + m_cf.rCoordAbsXMin) / 2 Y2 = (m_cf.rCoordAbsYMax + m_cf.rCoordAbsYMin) / 2 xs = X2 - (W / 2) ys = Y2 - (H / 2) xd = W / CDec(width) yd = H / CDec(heigth) 'y1 = ys Dim bMEtJ As Boolean = False Dim bJulia0 As Boolean = False If m_prm.typeFract = TFractal.Julia Then bJulia0 = True If m_prm.typeFract = TFractal.MandelbrotEtJulia Then bMEtJ = True 'For y As Integer = 0 To heigth - 1 Parallel.For(0, heigth - 1, Sub(y) Dim y1 As Decimal = ys + yd * y Dim x1, r1, i1, r1pow2, i1pow2, rpow, rlastpow, rCount_f, rFactor, a, b As Decimal Dim idx% = y * width x1 = xs For x As Integer = 0 To width - 1 r1 = 0 i1 = 0 a = 0 b = 0 r1pow2 = 0 i1pow2 = 0 If bJulia0 OrElse bMEtJ Then a = m_prm.rRe b = m_prm.rIm r1 = x1 i1 = y1 r1pow2 = r1 * r1 i1pow2 = i1 * i1 End If rpow = 0 rlastpow = 0 Dim iNbIter% = 0 Do While iNbIter < m_iNbIterationsMax AndAlso rpow < 4 r1pow2 = r1 * r1 i1pow2 = i1 * i1 If bJulia0 Then i1 = 2 * i1 * r1 + b r1 = r1pow2 - i1pow2 + a ElseIf bMEtJ Then i1 = (2 * i1) * r1 + y1 + b r1 = r1pow2 - i1pow2 + x1 + a Else i1 = (2 * i1) * r1 + y1 r1 = r1pow2 - i1pow2 + x1 End If rlastpow = rpow rpow = r1pow2 + i1pow2 iNbIter += 1 Loop Dim bFrontiere As Boolean = False If iNbIter >= m_iNbIterationsMax Then bFrontiere = True 'If rpow >= 4 Then Dans ce cas on a quitté la boucle sans atteindre la frontière ' Noter le nombre min. d'itérations pour déterminer le max. If iNbIter < m_iNbIterationsMin Then m_iNbIterationsMin = iNbIter Dim bInterpoler As Boolean = Not m_prmPalette.bFrontiereUnie If bInterpoler AndAlso bFrontiere Then rCount_f = iNbIter - 1 + (4 - rlastpow) / (rpow - rlastpow) rFactor = (1D - iNbIter + rCount_f) * 255 Dim iFactor% = 0 If rFactor >= Integer.MinValue AndAlso rFactor <= Integer.MaxValue Then iFactor = CInt(rFactor) Dim iCoul1% = iCalculerCouleur(iNbIter - 1, bFrontiere:=False) Dim iCoul2% = iCalculerCouleur(iNbIter, bFrontiere:=False) dst(idx) = InterpolateColors(iCoul1, iCoul2, iFactor) idx += 1 'Dim factor As Integer = CInt(((1.0 - (iter - count_f)) * 255)) 'dst(idx++) = Utils.InterpolateColors(Palette((iter - 1)), Palette(iter), factor) Else 'iNbIter = (iNbIter Mod Palette.Length) 'dst(idx) = Palette(iNbIter) Dim iIndiceCoul% = iCalculerCouleur(iNbIter, bFrontiere) dst(idx) = m_palette(iIndiceCoul) idx += 1 End If x1 += xd Next x 'y1 += yd End Sub) 'Next y ' Filtrage bilinéaire : appliquer un flou calculé en 2D pour éviter la pixellisation ' https://fr.wikipedia.org/wiki/Filtrage_bilinéaire ' Le filtrage bilinéaire est un algorithme utilisé en infographie permettant de calculer des ' pixels intermédiaires entre les pixels d'une image ou d'une texture que l'on change de taille. ' C'est un des procédés les plus utilisés depuis la fin des années 1990 par les cartes ' accélératrices 3D pour éviter l'effet de crènelage apparaissant dans le cas d'un filtrage linéaire. ' Ce filtrage utilise une interpolation bilinéaire qui, contrairement à une interpolation linéaire ' qui se contente d'interpoler en 1D (sur les lignes par exemple), l'interpolation est faite ' en 2D (lignes, colonnes). Ceci résulte en un effet de flou, bien plus agréable à l'œil que ' les carrés ou rectangles visibles habituellement sur une image agrandie. If m_prmPalette.bLisser Then RaiseEvent EvMajAvancement(80) Dim filteredColorTable As Integer() = New Integer(width * heigth - 1) {} Dim idxs11% = 0 Dim idxs12% = 0 Dim idxs21% = 0 Dim idxs22% = 0 For y As Integer = 0 To (heigth - 1) - 1 idxs11 = y * width idxs12 = idxs11 + 1 idxs21 = idxs11 + width idxs22 = idxs21 + 1 For x As Integer = 0 To (width - 1) - 1 Dim colf1% = InterpolateColors(dst(idxs11), dst(idxs12), &H7F) Dim colf2% = InterpolateColors(dst(idxs21), dst(idxs22), &H7F) filteredColorTable(idxs11) = InterpolateColors(colf1, colf2, &H80) idxs11 += 1 idxs12 += 1 idxs21 += 1 idxs22 += 1 Next Next dst = filteredColorTable End If RaiseEvent EvMajAvancement(90) Marshal.Copy(dst, 0, pscan0, dst.Length - 1) Me.m_bmpCache.UnlockBits(pdate) RaiseEvent EvMajBmp() RaiseEvent EvMajAvancement(100) End Sub #End Region End Class clsFractRemplissage.vb ' Fichier ClsFractRemplissage.vb ' ------------------------------ Public Class ClsFractRemplissage : Inherits clsFract #Region "Déclarations" ' Shadows indique que l'on masque l'événement de la classe de base Public Shadows Event EvMajBmp() ' Définition de l'avancement du remplissage : ' on se base sur la proportion de pixels à examiner, ' proportion obtenue à la résolution précédente Public Shadows Event EvMajAvancement(iAvancement%) Private m_iNbPixels% ' Nombre de pixels examinés Private m_rTauxMaxSurfaceRemp! ' Taux max. de surface remplie ' Taux min. de surface remplie lorsque la résolution des images augmente Private m_rTauxMinSurfaceRempImages! ' Par convention, 0 est le code d'un pixel non examiné 'Protected Const iCodePixelNonExamine% = 0 'Protected Const iCodePixelFrontiere% = 1 : défini dans la classe de base 'Private Const iCodePixelDessin% = 2 ' Tableau pour mémoriser les codes des pixels analysés Protected m_aiCodesPixel(,) As Byte Protected m_pile As New ClsPile() #End Region #Region "Tracé des images fractales avec le remplissage" Protected Overrides Sub InitialiserTracerFract() ' Par défaut toute l'image doit être remplie m_rTauxMinSurfaceRempImages = 1 End Sub Protected Overrides Sub TracerFract(iPas%) m_rTauxMaxSurfaceRemp = 0 m_iNbPixels = 0 Dim iPaveX%, iPaveY% ReDim m_aiCodesPixel(m_cf.iPaveMaxX, m_cf.iPaveMaxY) m_pile.Initialiser() If bDebugRemp Then If Not bRemplissage(0, 0, iPas) Then Exit Sub Exit Sub End If iPaveY = 0 For iPaveX = 0 To m_cf.iPaveMaxX - 1 If m_aiCodesPixel(iPaveX, iPaveY) = iCodePixelNonExamine Then _ If Not bRemplissage(iPaveX, iPaveY, iPas) Then Exit Sub Next iPaveX iPaveX = m_cf.iPaveMaxX For iPaveY = 0 To m_cf.iPaveMaxY - 1 If m_aiCodesPixel(iPaveX, iPaveY) = iCodePixelNonExamine Then _ If Not bRemplissage(iPaveX, iPaveY, iPas) Then Exit Sub Next iPaveY iPaveY = m_cf.iPaveMaxY For iPaveX = m_cf.iPaveMaxX To 0 Step -1 ' 03/08/2014 If m_aiCodesPixel(iPaveX, iPaveY) = iCodePixelNonExamine Then _ If Not bRemplissage(iPaveX, iPaveY, iPas) Then Exit Sub Next iPaveX iPaveX = 0 For iPaveY = m_cf.iPaveMaxY - 1 To 1 Step -1 ' 03/08/2014 If m_aiCodesPixel(iPaveX, iPaveY) = iCodePixelNonExamine Then _ If Not bRemplissage(iPaveX, iPaveY, iPas) Then Exit Sub Next iPaveY If m_rTauxMaxSurfaceRemp < m_rTauxMinSurfaceRempImages Then _ m_rTauxMinSurfaceRempImages = m_rTauxMaxSurfaceRemp RaiseEvent EvMajAvancement(100) End Sub Protected Overridable Function bRemplissage(iPaveX%, iPaveY%, iPas%) _ As Boolean If m_bQuitterTrace Then Exit Function If iPaveX < 0 OrElse iPaveX > m_cf.iPaveMaxX OrElse iPaveY < 0 OrElse iPaveY > m_cf.iPaveMaxY Then GoTo Echec ' On peut initialiser la pile à chaque remplissage, on est quand même sûr ' que l'on oubliera aucun pixels (car le remplissage est redondant), ' et la taille de la pile sera plus faible m_pile.Initialiser() If Not m_pile.bEmpiler(iPaveX, iPaveY) Then GoTo Echec Dim bRestePixel As Boolean bRestePixel = False Dim pt As PointPile ' PointShort Dim iNbIterations% Dim iCodePixel As Byte Do ' 04/08/2014 If m_pile.bPileVide Then GoTo ParcourirPile pt = m_pile.ptDepilerPtPile iPaveX = pt.X iPaveY = pt.Y If m_aiCodesPixel(iPaveX, iPaveY) <> iCodePixelNonExamine Then _ GoTo ParcourirPile ' Pixel déjà examiné bRestePixel = True m_iNbPixels += 1 m_cf.rXAbs = (iPaveX + 0.5D) * m_cf.rLargPaveAbs + m_cf.rCoordAbsXMin m_cf.rYAbs = (iPaveY + 0.5D) * m_cf.rHautPaveAbs + m_cf.rCoordAbsYMin Dim bFrontiere As Boolean = False iNbIterations = iCompterIterations(m_cf.rXAbs, m_cf.rYAbs, iPaveX, iPaveY, iPas, m_cf, bFrontiere) If bFrontiere Then iCodePixel = iCodePixelDessin Else iCodePixel = iCodePixelFrontiere End If m_aiCodesPixel(iPaveX, iPaveY) = iCodePixel If bFrontiere AndAlso Not bAfficherPixelsFrontiereModeRemplissage Then GoTo ParcourirPile Dim bInterpoler As Boolean = Not m_prmPalette.bFrontiereUnie If Not m_bAlgoRapide Then bInterpoler = False ' Ne marche qu'avec l'algo. rapide If bInterpoler AndAlso bFrontiere Then m_remplissage.Color = m_prm.coulInterpolee Else m_remplissage.Color = CouleurPalette(iNbIterations, bFrontiere) End If m_gr.FillRectangle(m_remplissage, m_cf.iMargeX + iPaveX * iPas, m_cf.iMargeY + iPaveY * iPas, iPas, iPas) If bDebugRemp Then RaiseEvent EvMajBmp() End If ' Si on interpole, cela ne sert plus à rien de faire du remplissage If bFrontiere And Not bInterpoler Then GoTo ParcourirPile ' Coeur de l'algorithme de remplissage If iPaveY > 0 AndAlso m_aiCodesPixel(iPaveX, iPaveY - 1) = iCodePixelNonExamine Then _ If Not m_pile.bEmpiler(iPaveX, iPaveY - 1) Then GoTo Echec If iPaveX > 0 AndAlso m_aiCodesPixel(iPaveX - 1, iPaveY) = iCodePixelNonExamine Then _ If Not m_pile.bEmpiler(iPaveX - 1, iPaveY) Then GoTo Echec If iPaveY < m_cf.iPaveMaxY AndAlso m_aiCodesPixel(iPaveX, iPaveY + 1) = iCodePixelNonExamine Then _ If Not m_pile.bEmpiler(iPaveX, iPaveY + 1) Then GoTo Echec If iPaveX < m_cf.iPaveMaxX AndAlso m_aiCodesPixel(iPaveX + 1, iPaveY) = iCodePixelNonExamine Then _ If Not m_pile.bEmpiler(iPaveX + 1, iPaveY) Then GoTo Echec ParcourirPile: Dim bBouclePile As Boolean If bClassePilePerso Then bBouclePile = m_pile.bParcourirPile Else bBouclePile = m_pile.bPileVide End If If bBouclePile Then If Not bRestePixel Then Exit Do bRestePixel = False RaiseEvent EvMajBmp() If m_rTauxMinSurfaceRempImages > 0 Then Dim rTauxSurfaceRemp! = CSng(m_iNbPixels / ((m_cf.iPaveMaxX + 1) * (m_cf.iPaveMaxY + 1))) Dim iAv% = CInt(100 * rTauxSurfaceRemp / m_rTauxMinSurfaceRempImages) RaiseEvent EvMajAvancement(iAv) End If Else ' 04/08/2014 Rafraichir l'écran à chaque itération : optimiser ? ToDo If m_pile.bMajBmp() Then RaiseEvent EvMajBmp() End If If bQuitter() Then Exit Function Loop While Not m_bQuitterTrace Dim rTauxSurfaceRempFin! = CSng(m_iNbPixels / ((m_cf.iPaveMaxX + 1) * (m_cf.iPaveMaxY + 1))) If rTauxSurfaceRempFin > m_rTauxMaxSurfaceRemp Then _ m_rTauxMaxSurfaceRemp = rTauxSurfaceRempFin bRemplissage = Not m_bQuitterTrace Exit Function Echec: Exit Function End Function #End Region End Class clsPile.vb Imports System.Collections.Generic #Const iClassePilePerso = 0 #Const iClassePileGeneric = 1 ' La classe perso. ne marche plus, car elle n'est pas compatible avec les QuadTree ' (les indices de lecture et écriture se mélangent entre les niveaux : cela ne peut ' marcher qu'avec un seul niveau !?) '#Const iClassePile = iClassePilePerso #Const iClassePile = iClassePileGeneric #Region "Structure PointPile" ' Structure de point optimisée pour la classe de pile suivante ' SizeOf PointPile = 12 octets Public Structure PointPile Public X, Y As Short #If iClassePile = iClassePilePerso Then Public bDejaTrace As Boolean ' Utile que pour l'algo QuadTree #End If Public Sub New(iX%, iY%) X = CShort(iX) Y = CShort(iY) End Sub End Structure #End Region #If iClassePile = iClassePilePerso Then Module modPile Public bClassePilePerso As Boolean = True End Module ' Classe pour gérer une pile de pixels ' On arrive au même résultat en utilisant une collection, ' mais c'est alors 30 fois + lent : ' Dim collec As New Collection() avec collec.Add(pt) Public Class ClsPile Private m_aptPile() As PointPile ' Pile de pixels à analyser Private m_iIndicePileMax% Private m_iIndicePileL% ' Lecture Private m_iIndicePileE% ' Ecriture Public ReadOnly Property bPileVide() As Boolean Get If m_iIndicePileMax = -1 Then bPileVide = True End Get End Property Public Sub Initialiser() m_iIndicePileMax = -1 m_iIndicePileE = -1 m_iIndicePileL = -1 End Sub Public Function bEmpiler(iX%, iY%) As Boolean 'Debug.WriteLine("Empilage : " & iX & ", " & iY & ", max.:" & m_iIndicePileMax) bEmpiler = True ' Si on atteint la fin de pile, on réutilise les emplacements ' au début de la pile ' Bug de la version 4 corrigé : m_iIndicePileE + 1 <> m_iIndicePileL If m_iIndicePileE + 1 = m_iIndicePileMax And m_iIndicePileE + 1 <> m_iIndicePileL Then m_iIndicePileE = -1 ' Si on rattrape l'indice en lecture de la pile, ' ou bien si on dépasse l'indice max. de la pile, ' on redimmensionne la pile, et on stocke le point ' en fin de pile Dim iIndiceEmpile% If (m_iIndicePileE + 1 = m_iIndicePileL OrElse m_iIndicePileE + 1 > m_iIndicePileMax) AndAlso Not (m_iIndicePileE + 1 = 0 AndAlso m_iIndicePileL = 0 AndAlso m_iIndicePileMax = 0) Then ' Augmentation dynamique de la taille de la pile Try m_iIndicePileMax += 1 If m_iIndicePileMax = 0 Then ReDim m_aptPile(m_iIndicePileMax) m_iIndicePileL = 0 m_iIndicePileE = 0 Else ReDim Preserve m_aptPile(m_iIndicePileMax) End If iIndiceEmpile = m_iIndicePileMax Catch bEmpiler = False ' Plus assez de mémoire vive, ça craint ! Exit Function End Try Else ' On stocke le point à l'indice en écriture m_iIndicePileE += 1 ' On veut empiler un nouveau point iIndiceEmpile = m_iIndicePileE End If m_aptPile(iIndiceEmpile) = New PointPile(iX, iY) End Function Public Function ptDepilerPtPile() As PointPile If m_iIndicePileMax = -1 Then Exit Function ptDepilerPtPile = m_aptPile(m_iIndicePileL) End Function Public Function bParcourirPile() As Boolean ' On parcours la pile et on renvoit True si on reboucle (ou si vide) m_iIndicePileL += 1 ' Bug de la version 4 corrigé : > et non >= If m_iIndicePileL > m_iIndicePileMax Then _ m_iIndicePileL = 0 : bParcourirPile = True End Function Public Function bMajBmp() As Boolean If ((m_iIndicePileL + 1) Mod 200) = 0 Then bMajBmp = True End Function End Class #ElseIf iClassePile = iClassePileGeneric Then Module modPile Public bClassePilePerso As Boolean = False End Module ' Classe pour gérer une pile de pixels ' On arrive au même résultat en utilisant une collection, ' mais c'est alors 30 fois + lent : ' Dim collec As New Collection() avec collec.Add(pt) Public Class ClsPile Private m_dTpsDeb As Date Private m_aptPile As New Queue(Of PointPile) Private m_iCompteur% Public ReadOnly Property bPileVide() As Boolean Get Return (m_aptPile.Count = 0) Return False End Get End Property Public Sub Initialiser() m_aptPile = New Queue(Of PointPile) m_iCompteur = 0 m_dTpsDeb = Now() End Sub Public Function bEmpiler(iX%, iY%) As Boolean m_aptPile.Enqueue(New PointPile(iX, iY)) Return True End Function Public Function ptDepilerPtPile() As PointPile Return m_aptPile.Dequeue() End Function Public Function bParcourirPile() As Boolean End Function Public Function bMajBmp() As Boolean m_iCompteur += 1 If (m_iCompteur Mod 50) = 0 Then ' Vérifier le tps toutes les 200 itérations Dim ts As TimeSpan = Now() - m_dTpsDeb Dim rNbSec# = ts.TotalSeconds() If rNbSec >= 0.5# Then ' Màj chaque 1/2 sec. bMajBmp = True m_dTpsDeb = Now End If End If End Function End Class #End If frmConfig.vb ' Fichier FrmConfig.vb : Configuration de Fractalis ' -------------------- Public Class frmConfig : Inherits Form Public Event EvZoomMoins() Public Event EvZoomInit() Public Event EvAppliquer() Public Event EvPause() Public Event EvStop() Public Event EvDetailIterations() Public Event EvModeTranslation() ' Amplitude max. (en coord. absolue) que l'on peut fixer ' dans la petite fenêtre pour le paramètre de Julia Private Const iAmplitPrmJulia% = 10 Private m_ptfJulia As PointF Private m_bPaletteModifiee As Boolean ' Vérifier si la palette calculée est modifiée Private m_typeFract As TFractal Private m_bJulia As Boolean Friend WithEvents chkModeTranslation As System.Windows.Forms.CheckBox Friend WithEvents rbMandelbrotEtJulia As System.Windows.Forms.RadioButton Friend WithEvents pnlVideo As System.Windows.Forms.Panel #Region " Windows Form Designer generated code " Public Sub New() MyBase.New() 'This call is required by the Windows Form Designer. InitializeComponent() 'Add any initialization after the InitializeComponent() call End Sub 'Form overrides dispose to clean up the component list. Protected Overloads Overrides Sub Dispose(disposing As Boolean) If disposing Then If Not (components Is Nothing) Then components.Dispose() End If End If MyBase.Dispose(disposing) End Sub 'Required by the Windows Form Designer Private components As System.ComponentModel.IContainer 'NOTE: The following procedure is required by the Windows Form Designer 'It can be modified using the Windows Form Designer. 'Do not modify it using the code editor. Friend WithEvents grpbTypeFract As System.Windows.Forms.GroupBox Friend WithEvents rbJulia As System.Windows.Forms.RadioButton Friend WithEvents rbMandelbrot As System.Windows.Forms.RadioButton Friend WithEvents nudDegre As System.Windows.Forms.NumericUpDown Friend WithEvents LblDegre As System.Windows.Forms.Label Friend WithEvents cmdPause As System.Windows.Forms.Button Friend WithEvents cmdStop As System.Windows.Forms.Button Friend WithEvents cmdAppliquer As System.Windows.Forms.Button Friend WithEvents pbAvancement As System.Windows.Forms.ProgressBar Friend WithEvents nudNbIterationsMax As System.Windows.Forms.NumericUpDown Friend WithEvents lblIterationMax As System.Windows.Forms.Label Friend WithEvents cmdZoomInit As System.Windows.Forms.Button Friend WithEvents ToolTip1 As System.Windows.Forms.ToolTip Friend WithEvents cmdZoomMoins As System.Windows.Forms.Button Friend WithEvents lblZoom As System.Windows.Forms.Label Friend WithEvents chkEffacerImg As System.Windows.Forms.CheckBox Friend WithEvents chkModeDetailIterations As System.Windows.Forms.CheckBox Friend WithEvents pbxJulia As System.Windows.Forms.PictureBox Friend WithEvents lblPrmJulia As System.Windows.Forms.Label Friend WithEvents txtJuliaX As System.Windows.Forms.TextBox Friend WithEvents txtJuliaY As System.Windows.Forms.TextBox Friend WithEvents panelJulia As System.Windows.Forms.Panel Friend WithEvents pnlPalette As System.Windows.Forms.Panel Friend WithEvents chkPaletteSysteme As System.Windows.Forms.CheckBox Friend WithEvents nudPremCouleur As System.Windows.Forms.NumericUpDown Friend WithEvents Label2 As System.Windows.Forms.Label Friend WithEvents Label1 As System.Windows.Forms.Label Friend WithEvents nudNbCouleurs As System.Windows.Forms.NumericUpDown Friend WithEvents Label3 As System.Windows.Forms.Label Friend WithEvents nudNbCyclesDegrade As System.Windows.Forms.NumericUpDown Friend WithEvents pbxVerif As System.Windows.Forms.PictureBox Friend WithEvents chkPaletteAleatoire As System.Windows.Forms.CheckBox Friend WithEvents chkMire As System.Windows.Forms.CheckBox Friend WithEvents chkFrontiereUnie As System.Windows.Forms.CheckBox Friend WithEvents chkLisser As System.Windows.Forms.CheckBox Friend WithEvents chkDecimal As System.Windows.Forms.CheckBox Friend WithEvents chkAlgoRapide As System.Windows.Forms.CheckBox <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent() Me.components = New System.ComponentModel.Container() Me.grpbTypeFract = New System.Windows.Forms.GroupBox() Me.rbMandelbrotEtJulia = New System.Windows.Forms.RadioButton() Me.rbJulia = New System.Windows.Forms.RadioButton() Me.rbMandelbrot = New System.Windows.Forms.RadioButton() Me.nudDegre = New System.Windows.Forms.NumericUpDown() Me.LblDegre = New System.Windows.Forms.Label() Me.cmdPause = New System.Windows.Forms.Button() Me.cmdStop = New System.Windows.Forms.Button() Me.cmdAppliquer = New System.Windows.Forms.Button() Me.cmdZoomInit = New System.Windows.Forms.Button() Me.chkEffacerImg = New System.Windows.Forms.CheckBox() Me.pbAvancement = New System.Windows.Forms.ProgressBar() Me.nudNbIterationsMax = New System.Windows.Forms.NumericUpDown() Me.lblIterationMax = New System.Windows.Forms.Label() Me.cmdZoomMoins = New System.Windows.Forms.Button() Me.ToolTip1 = New System.Windows.Forms.ToolTip(Me.components) Me.chkModeDetailIterations = New System.Windows.Forms.CheckBox() Me.txtJuliaY = New System.Windows.Forms.TextBox() Me.txtJuliaX = New System.Windows.Forms.TextBox() Me.pbxJulia = New System.Windows.Forms.PictureBox() Me.pnlPalette = New System.Windows.Forms.Panel() Me.chkLisser = New System.Windows.Forms.CheckBox() Me.chkFrontiereUnie = New System.Windows.Forms.CheckBox() Me.chkPaletteAleatoire = New System.Windows.Forms.CheckBox() Me.pbxVerif = New System.Windows.Forms.PictureBox() Me.Label3 = New System.Windows.Forms.Label() Me.nudNbCyclesDegrade = New System.Windows.Forms.NumericUpDown() Me.nudPremCouleur = New System.Windows.Forms.NumericUpDown() Me.Label2 = New System.Windows.Forms.Label() Me.Label1 = New System.Windows.Forms.Label() Me.nudNbCouleurs = New System.Windows.Forms.NumericUpDown() Me.chkMire = New System.Windows.Forms.CheckBox() Me.chkPaletteSysteme = New System.Windows.Forms.CheckBox() Me.chkDecimal = New System.Windows.Forms.CheckBox() Me.chkAlgoRapide = New System.Windows.Forms.CheckBox() Me.chkModeTranslation = New System.Windows.Forms.CheckBox() Me.pnlVideo = New System.Windows.Forms.Panel() Me.lblZoom = New System.Windows.Forms.Label() Me.panelJulia = New System.Windows.Forms.Panel() Me.lblPrmJulia = New System.Windows.Forms.Label() Me.grpbTypeFract.SuspendLayout() CType(Me.nudDegre, System.ComponentModel.ISupportInitialize).BeginInit() CType(Me.nudNbIterationsMax, System.ComponentModel.ISupportInitialize).BeginInit() CType(Me.pbxJulia, System.ComponentModel.ISupportInitialize).BeginInit() Me.pnlPalette.SuspendLayout() CType(Me.pbxVerif, System.ComponentModel.ISupportInitialize).BeginInit() CType(Me.nudNbCyclesDegrade, System.ComponentModel.ISupportInitialize).BeginInit() CType(Me.nudPremCouleur, System.ComponentModel.ISupportInitialize).BeginInit() CType(Me.nudNbCouleurs, System.ComponentModel.ISupportInitialize).BeginInit() Me.pnlVideo.SuspendLayout() Me.panelJulia.SuspendLayout() Me.SuspendLayout() ' 'grpbTypeFract ' Me.grpbTypeFract.Controls.Add(Me.rbMandelbrotEtJulia) Me.grpbTypeFract.Controls.Add(Me.rbJulia) Me.grpbTypeFract.Controls.Add(Me.rbMandelbrot) Me.grpbTypeFract.Location = New System.Drawing.Point(8, 8) Me.grpbTypeFract.Name = "grpbTypeFract" Me.grpbTypeFract.Size = New System.Drawing.Size(112, 90) Me.grpbTypeFract.TabIndex = 0 Me.grpbTypeFract.TabStop = False Me.grpbTypeFract.Text = "Ensemble de type" Me.ToolTip1.SetToolTip(Me.grpbTypeFract, "Types d'ensemble fractal à dessiner") ' 'rbMandelbrotEtJulia ' Me.rbMandelbrotEtJulia.Location = New System.Drawing.Point(16, 70) Me.rbMandelbrotEtJulia.Name = "rbMandelbrotEtJulia" Me.rbMandelbrotEtJulia.Size = New System.Drawing.Size(90, 16) Me.rbMandelbrotEtJulia.TabIndex = 2 Me.rbMandelbrotEtJulia.Text = "Mdb + Julia" ' 'rbJulia ' Me.rbJulia.Location = New System.Drawing.Point(16, 48) Me.rbJulia.Name = "rbJulia" Me.rbJulia.Size = New System.Drawing.Size(80, 16) Me.rbJulia.TabIndex = 1 Me.rbJulia.Text = "Julia" ' 'rbMandelbrot ' Me.rbMandelbrot.Checked = True Me.rbMandelbrot.Location = New System.Drawing.Point(16, 24) Me.rbMandelbrot.Name = "rbMandelbrot" Me.rbMandelbrot.Size = New System.Drawing.Size(80, 16) Me.rbMandelbrot.TabIndex = 0 Me.rbMandelbrot.TabStop = True Me.rbMandelbrot.Text = "Mandelbrot" ' 'nudDegre ' Me.nudDegre.Location = New System.Drawing.Point(176, 16) Me.nudDegre.Maximum = New Decimal(New Integer() {5, 0, 0, 0}) Me.nudDegre.Minimum = New Decimal(New Integer() {2, 0, 0, 0}) Me.nudDegre.Name = "nudDegre" Me.nudDegre.Size = New System.Drawing.Size(32, 20) Me.nudDegre.TabIndex = 1 Me.nudDegre.Value = New Decimal(New Integer() {2, 0, 0, 0}) ' 'LblDegre ' Me.LblDegre.Location = New System.Drawing.Point(128, 16) Me.LblDegre.Name = "LblDegre" Me.LblDegre.Size = New System.Drawing.Size(48, 16) Me.LblDegre.TabIndex = 5 Me.LblDegre.Text = "Degré :" Me.ToolTip1.SetToolTip(Me.LblDegre, "Degré de l'équation Z -> Z^degré + C") ' 'cmdPause ' Me.cmdPause.Location = New System.Drawing.Point(120, 296) Me.cmdPause.Name = "cmdPause" Me.cmdPause.Size = New System.Drawing.Size(96, 24) Me.cmdPause.TabIndex = 8 Me.cmdPause.Text = "Pause / Reprise" Me.ToolTip1.SetToolTip(Me.cmdPause, "Faire une pause / reprendre le tracé") ' 'cmdStop ' Me.cmdStop.Location = New System.Drawing.Point(120, 328) Me.cmdStop.Name = "cmdStop" Me.cmdStop.Size = New System.Drawing.Size(96, 24) Me.cmdStop.TabIndex = 9 Me.cmdStop.Text = "Stop" Me.ToolTip1.SetToolTip(Me.cmdStop, "Arrêter le tracé") ' 'cmdAppliquer ' Me.cmdAppliquer.Location = New System.Drawing.Point(8, 264) Me.cmdAppliquer.Name = "cmdAppliquer" Me.cmdAppliquer.Size = New System.Drawing.Size(208, 24) Me.cmdAppliquer.TabIndex = 5 Me.cmdAppliquer.Text = "Appliquer" Me.ToolTip1.SetToolTip(Me.cmdAppliquer, "Appliquer ces paramètres et retracer") ' 'cmdZoomInit ' Me.cmdZoomInit.Location = New System.Drawing.Point(8, 328) Me.cmdZoomInit.Name = "cmdZoomInit" Me.cmdZoomInit.Size = New System.Drawing.Size(96, 24) Me.cmdZoomInit.TabIndex = 7 Me.cmdZoomInit.Tag = "" Me.cmdZoomInit.Text = "Zoom Init." Me.ToolTip1.SetToolTip(Me.cmdZoomInit, "Ré-initialiser le zoom") ' 'chkEffacerImg ' Me.chkEffacerImg.Location = New System.Drawing.Point(8, 232) Me.chkEffacerImg.Name = "chkEffacerImg" Me.chkEffacerImg.Size = New System.Drawing.Size(104, 24) Me.chkEffacerImg.TabIndex = 3 Me.chkEffacerImg.Text = "Effacer l'image" Me.ToolTip1.SetToolTip(Me.chkEffacerImg, "Effacer l'image à chaque affinage des pixels (en mode remplissage)") ' 'pbAvancement ' Me.pbAvancement.Anchor = CType(((System.Windows.Forms.AnchorStyles.Bottom Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right), System.Windows.Forms.AnchorStyles) Me.pbAvancement.Location = New System.Drawing.Point(8, 454) Me.pbAvancement.Name = "pbAvancement" Me.pbAvancement.Size = New System.Drawing.Size(412, 21) Me.pbAvancement.TabIndex = 13 ' 'nudNbIterationsMax ' Me.nudNbIterationsMax.Location = New System.Drawing.Point(131, 56) Me.nudNbIterationsMax.Maximum = New Decimal(New Integer() {32767, 0, 0, 0}) Me.nudNbIterationsMax.Name = "nudNbIterationsMax" Me.nudNbIterationsMax.Size = New System.Drawing.Size(88, 20) Me.nudNbIterationsMax.TabIndex = 2 Me.nudNbIterationsMax.Value = New Decimal(New Integer() {166, 0, 0, 0}) ' 'lblIterationMax ' Me.lblIterationMax.Location = New System.Drawing.Point(128, 39) Me.lblIterationMax.Name = "lblIterationMax" Me.lblIterationMax.Size = New System.Drawing.Size(80, 16) Me.lblIterationMax.TabIndex = 16 Me.lblIterationMax.Text = "Itération max.:" Me.ToolTip1.SetToolTip(Me.lblIterationMax, "Itération maximum de l'équation Z -> Z^degré + C") ' 'cmdZoomMoins ' Me.cmdZoomMoins.Location = New System.Drawing.Point(8, 296) Me.cmdZoomMoins.Name = "cmdZoomMoins" Me.cmdZoomMoins.Size = New System.Drawing.Size(96, 24) Me.cmdZoomMoins.TabIndex = 6 Me.cmdZoomMoins.Tag = "" Me.cmdZoomMoins.Text = "Zoom -" Me.ToolTip1.SetToolTip(Me.cmdZoomMoins, "Reculer le zoom") ' 'chkModeDetailIterations ' Me.chkModeDetailIterations.Location = New System.Drawing.Point(120, 232) Me.chkModeDetailIterations.Name = "chkModeDetailIterations" Me.chkModeDetailIterations.Size = New System.Drawing.Size(104, 24) Me.chkModeDetailIterations.TabIndex = 4 Me.chkModeDetailIterations.Text = "Détail itérations" Me.ToolTip1.SetToolTip(Me.chkModeDetailIterations, "Afficher le détail des itérations sur un pixel pointé à la souris") ' 'txtJuliaY ' Me.txtJuliaY.Anchor = CType(((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right), System.Windows.Forms.AnchorStyles) Me.txtJuliaY.Location = New System.Drawing.Point(112, 88) Me.txtJuliaY.Name = "txtJuliaY" Me.txtJuliaY.Size = New System.Drawing.Size(96, 20) Me.txtJuliaY.TabIndex = 1 Me.txtJuliaY.Text = "0" Me.ToolTip1.SetToolTip(Me.txtJuliaY, "Saisissez directement la valeur Y du paramètre de Julia") ' 'txtJuliaX ' Me.txtJuliaX.Anchor = CType(((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right), System.Windows.Forms.AnchorStyles) Me.txtJuliaX.Location = New System.Drawing.Point(112, 56) Me.txtJuliaX.Name = "txtJuliaX" Me.txtJuliaX.Size = New System.Drawing.Size(96, 20) Me.txtJuliaX.TabIndex = 0 Me.txtJuliaX.Text = "0" Me.ToolTip1.SetToolTip(Me.txtJuliaX, "Saisissez directement la valeur X du paramètre de Julia") ' 'pbxJulia ' Me.pbxJulia.BackColor = System.Drawing.Color.Aqua Me.pbxJulia.Location = New System.Drawing.Point(8, 8) Me.pbxJulia.Name = "pbxJulia" Me.pbxJulia.Size = New System.Drawing.Size(100, 100) Me.pbxJulia.TabIndex = 20 Me.pbxJulia.TabStop = False Me.ToolTip1.SetToolTip(Me.pbxJulia, "Sélectionner le paramètre de Julia en cliquant dans la zone") ' 'pnlPalette ' Me.pnlPalette.BorderStyle = System.Windows.Forms.BorderStyle.Fixed3D Me.pnlPalette.Controls.Add(Me.chkLisser) Me.pnlPalette.Controls.Add(Me.chkFrontiereUnie) Me.pnlPalette.Controls.Add(Me.chkPaletteAleatoire) Me.pnlPalette.Controls.Add(Me.pbxVerif) Me.pnlPalette.Controls.Add(Me.Label3) Me.pnlPalette.Controls.Add(Me.nudNbCyclesDegrade) Me.pnlPalette.Controls.Add(Me.nudPremCouleur) Me.pnlPalette.Controls.Add(Me.Label2) Me.pnlPalette.Controls.Add(Me.Label1) Me.pnlPalette.Controls.Add(Me.nudNbCouleurs) Me.pnlPalette.Controls.Add(Me.chkMire) Me.pnlPalette.Controls.Add(Me.chkPaletteSysteme) Me.pnlPalette.Location = New System.Drawing.Point(230, 16) Me.pnlPalette.Name = "pnlPalette" Me.pnlPalette.Size = New System.Drawing.Size(155, 320) Me.pnlPalette.TabIndex = 11 Me.ToolTip1.SetToolTip(Me.pnlPalette, "Options de la palette de couleur") ' 'chkLisser ' Me.chkLisser.Location = New System.Drawing.Point(87, 145) Me.chkLisser.Name = "chkLisser" Me.chkLisser.Size = New System.Drawing.Size(61, 24) Me.chkLisser.TabIndex = 24 Me.chkLisser.Text = "Lisser" Me.ToolTip1.SetToolTip(Me.chkLisser, "Lisser les couleurs avec un effet de flou (pour l'algorithme rapide seulement)") ' 'chkFrontiereUnie ' Me.chkFrontiereUnie.Location = New System.Drawing.Point(87, 202) Me.chkFrontiereUnie.Name = "chkFrontiereUnie" Me.chkFrontiereUnie.Size = New System.Drawing.Size(61, 24) Me.chkFrontiereUnie.TabIndex = 23 Me.chkFrontiereUnie.Text = "Front." Me.ToolTip1.SetToolTip(Me.chkFrontiereUnie, "Afficher la frontière sous une couleur unie, ou sinon interpoler les couleurs (po" & "ur l'algorithme rapide seulement)") ' 'chkPaletteAleatoire ' Me.chkPaletteAleatoire.Location = New System.Drawing.Point(12, 241) Me.chkPaletteAleatoire.Name = "chkPaletteAleatoire" Me.chkPaletteAleatoire.Size = New System.Drawing.Size(104, 24) Me.chkPaletteAleatoire.TabIndex = 8 Me.chkPaletteAleatoire.Text = "Palette alétoire" Me.ToolTip1.SetToolTip(Me.chkPaletteAleatoire, "Répartir les dégradés de couleur aléatoirement") ' 'pbxVerif ' Me.pbxVerif.Anchor = CType(((System.Windows.Forms.AnchorStyles.Bottom Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right), System.Windows.Forms.AnchorStyles) Me.pbxVerif.BackColor = System.Drawing.Color.LimeGreen Me.pbxVerif.Location = New System.Drawing.Point(37, 271) Me.pbxVerif.Name = "pbxVerif" Me.pbxVerif.Size = New System.Drawing.Size(79, 25) Me.pbxVerif.TabIndex = 22 Me.pbxVerif.TabStop = False Me.ToolTip1.SetToolTip(Me.pbxVerif, "L'indicateur est rouge si le nombre des 1024 couleurs n'est pas divisible par le " & "nombre de cycles (jusqu'à 32 cycles), il indique le risque d'avoir des défauts v" & "isibles dans la palette.") ' 'Label3 ' Me.Label3.Location = New System.Drawing.Point(9, 183) Me.Label3.Name = "Label3" Me.Label3.Size = New System.Drawing.Size(80, 16) Me.Label3.TabIndex = 6 Me.Label3.Text = "Nb. cycles :" Me.ToolTip1.SetToolTip(Me.Label3, "Nombre de cycles de dégradées de couleur dans la palette à 1024 couleurs") ' 'nudNbCyclesDegrade ' Me.nudNbCyclesDegrade.Location = New System.Drawing.Point(12, 202) Me.nudNbCyclesDegrade.Maximum = New Decimal(New Integer() {512, 0, 0, 0}) Me.nudNbCyclesDegrade.Minimum = New Decimal(New Integer() {1, 0, 0, 0}) Me.nudNbCyclesDegrade.Name = "nudNbCyclesDegrade" Me.nudNbCyclesDegrade.Size = New System.Drawing.Size(52, 20) Me.nudNbCyclesDegrade.TabIndex = 7 Me.nudNbCyclesDegrade.Value = New Decimal(New Integer() {32, 0, 0, 0}) ' 'nudPremCouleur ' Me.nudPremCouleur.Location = New System.Drawing.Point(12, 145) Me.nudPremCouleur.Maximum = New Decimal(New Integer() {167, 0, 0, 0}) Me.nudPremCouleur.Name = "nudPremCouleur" Me.nudPremCouleur.Size = New System.Drawing.Size(52, 20) Me.nudPremCouleur.TabIndex = 5 ' 'Label2 ' Me.Label2.Location = New System.Drawing.Point(9, 126) Me.Label2.Name = "Label2" Me.Label2.Size = New System.Drawing.Size(80, 16) Me.Label2.TabIndex = 4 Me.Label2.Text = "1ère couleur :" Me.ToolTip1.SetToolTip(Me.Label2, "Numéro de la 1ère couleur") ' 'Label1 ' Me.Label1.Location = New System.Drawing.Point(9, 67) Me.Label1.Name = "Label1" Me.Label1.Size = New System.Drawing.Size(80, 16) Me.Label1.TabIndex = 2 Me.Label1.Text = "Nb. couleurs :" Me.ToolTip1.SetToolTip(Me.Label1, "Nombre de couleurs") ' 'nudNbCouleurs ' Me.nudNbCouleurs.Location = New System.Drawing.Point(12, 86) Me.nudNbCouleurs.Maximum = New Decimal(New Integer() {167, 0, 0, 0}) Me.nudNbCouleurs.Minimum = New Decimal(New Integer() {1, 0, 0, 0}) Me.nudNbCouleurs.Name = "nudNbCouleurs" Me.nudNbCouleurs.Size = New System.Drawing.Size(52, 20) Me.nudNbCouleurs.TabIndex = 3 Me.nudNbCouleurs.Value = New Decimal(New Integer() {167, 0, 0, 0}) ' 'chkMire ' Me.chkMire.Location = New System.Drawing.Point(12, 8) Me.chkMire.Name = "chkMire" Me.chkMire.Size = New System.Drawing.Size(52, 24) Me.chkMire.TabIndex = 0 Me.chkMire.Text = "Mire" Me.ToolTip1.SetToolTip(Me.chkMire, "Afficher la palette") ' 'chkPaletteSysteme ' Me.chkPaletteSysteme.Location = New System.Drawing.Point(12, 38) Me.chkPaletteSysteme.Name = "chkPaletteSysteme" Me.chkPaletteSysteme.Size = New System.Drawing.Size(104, 24) Me.chkPaletteSysteme.TabIndex = 1 Me.chkPaletteSysteme.Text = "Palette système" Me.ToolTip1.SetToolTip(Me.chkPaletteSysteme, "Utiliser la palette système prédéfinie (167 couleurs max.), ou sinon la palette d" & "e 1024 couleurs dégradées en cycle(s)") ' 'chkDecimal ' Me.chkDecimal.Location = New System.Drawing.Point(8, 358) Me.chkDecimal.Name = "chkDecimal" Me.chkDecimal.Size = New System.Drawing.Size(73, 24) Me.chkDecimal.TabIndex = 17 Me.chkDecimal.Text = "Décimal" Me.ToolTip1.SetToolTip(Me.chkDecimal, "Calcul en Decimal au lieu de Double (plus lent, mais le zoom peut aller plus loin" & ")") ' 'chkAlgoRapide ' Me.chkAlgoRapide.Location = New System.Drawing.Point(120, 358) Me.chkAlgoRapide.Name = "chkAlgoRapide" Me.chkAlgoRapide.Size = New System.Drawing.Size(73, 24) Me.chkAlgoRapide.TabIndex = 18 Me.chkAlgoRapide.Text = "Rapide" Me.ToolTip1.SetToolTip(Me.chkAlgoRapide, "Utiliser l'algorithme rapide (degré 2 seulement)") ' 'chkModeTranslation ' Me.chkModeTranslation.Location = New System.Drawing.Point(24, 23) Me.chkModeTranslation.Name = "chkModeTranslation" Me.chkModeTranslation.Size = New System.Drawing.Size(104, 24) Me.chkModeTranslation.TabIndex = 19 Me.chkModeTranslation.Text = "Translation" Me.ToolTip1.SetToolTip(Me.chkModeTranslation, "Définir un chemin de translation à la souris") ' 'pnlVideo ' Me.pnlVideo.Controls.Add(Me.chkModeTranslation) Me.pnlVideo.Location = New System.Drawing.Point(402, 16) Me.pnlVideo.Name = "pnlVideo" Me.pnlVideo.Size = New System.Drawing.Size(22, 320) Me.pnlVideo.TabIndex = 20 Me.ToolTip1.SetToolTip(Me.pnlVideo, "Configuration du mode vidéo") ' 'lblZoom ' Me.lblZoom.Anchor = CType(((System.Windows.Forms.AnchorStyles.Bottom Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right), System.Windows.Forms.AnchorStyles) Me.lblZoom.Font = New System.Drawing.Font("Microsoft Sans Serif", 8.25!, System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, CType(0, Byte)) Me.lblZoom.Location = New System.Drawing.Point(8, 385) Me.lblZoom.Name = "lblZoom" Me.lblZoom.Size = New System.Drawing.Size(412, 66) Me.lblZoom.TabIndex = 12 Me.lblZoom.Text = "Prm Zoom" ' 'panelJulia ' Me.panelJulia.Controls.Add(Me.txtJuliaY) Me.panelJulia.Controls.Add(Me.txtJuliaX) Me.panelJulia.Controls.Add(Me.lblPrmJulia) Me.panelJulia.Controls.Add(Me.pbxJulia) Me.panelJulia.Enabled = False Me.panelJulia.Location = New System.Drawing.Point(8, 104) Me.panelJulia.Name = "panelJulia" Me.panelJulia.Size = New System.Drawing.Size(216, 120) Me.panelJulia.TabIndex = 5 ' 'lblPrmJulia ' Me.lblPrmJulia.Anchor = CType(((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right), System.Windows.Forms.AnchorStyles) Me.lblPrmJulia.Location = New System.Drawing.Point(120, 16) Me.lblPrmJulia.Name = "lblPrmJulia" Me.lblPrmJulia.Size = New System.Drawing.Size(88, 32) Me.lblPrmJulia.TabIndex = 21 Me.lblPrmJulia.Text = "Paramètres de Julia : X et Y" ' 'frmConfig ' Me.AutoScaleBaseSize = New System.Drawing.Size(5, 13) Me.ClientSize = New System.Drawing.Size(428, 480) Me.Controls.Add(Me.pnlVideo) Me.Controls.Add(Me.chkAlgoRapide) Me.Controls.Add(Me.chkDecimal) Me.Controls.Add(Me.pnlPalette) Me.Controls.Add(Me.panelJulia) Me.Controls.Add(Me.chkModeDetailIterations) Me.Controls.Add(Me.lblZoom) Me.Controls.Add(Me.cmdZoomMoins) Me.Controls.Add(Me.lblIterationMax) Me.Controls.Add(Me.nudNbIterationsMax) Me.Controls.Add(Me.pbAvancement) Me.Controls.Add(Me.chkEffacerImg) Me.Controls.Add(Me.cmdZoomInit) Me.Controls.Add(Me.cmdAppliquer) Me.Controls.Add(Me.cmdStop) Me.Controls.Add(Me.cmdPause) Me.Controls.Add(Me.LblDegre) Me.Controls.Add(Me.nudDegre) Me.Controls.Add(Me.grpbTypeFract) Me.Name = "frmConfig" Me.StartPosition = System.Windows.Forms.FormStartPosition.Manual Me.Text = "Configuration de Fractalis" Me.grpbTypeFract.ResumeLayout(False) CType(Me.nudDegre, System.ComponentModel.ISupportInitialize).EndInit() CType(Me.nudNbIterationsMax, System.ComponentModel.ISupportInitialize).EndInit() CType(Me.pbxJulia, System.ComponentModel.ISupportInitialize).EndInit() Me.pnlPalette.ResumeLayout(False) CType(Me.pbxVerif, System.ComponentModel.ISupportInitialize).EndInit() CType(Me.nudNbCyclesDegrade, System.ComponentModel.ISupportInitialize).EndInit() CType(Me.nudPremCouleur, System.ComponentModel.ISupportInitialize).EndInit() CType(Me.nudNbCouleurs, System.ComponentModel.ISupportInitialize).EndInit() Me.pnlVideo.ResumeLayout(False) Me.panelJulia.ResumeLayout(False) Me.panelJulia.PerformLayout() Me.ResumeLayout(False) End Sub #End Region #Region "Propriétés" Public Property bPaletteModifiee() As Boolean Get Return m_bPaletteModifiee End Get Set(value As Boolean) m_bPaletteModifiee = value End Set End Property Public Property bMire() As Boolean Get Return chkMire.Checked End Get Set(bVal As Boolean) chkMire.Checked = bVal End Set End Property Public Property bFrontiereUnie() As Boolean Get Return chkFrontiereUnie.Checked End Get Set(bVal As Boolean) chkFrontiereUnie.Checked = bVal End Set End Property Public Property bLisser() As Boolean Get Return chkLisser.Checked End Get Set(bVal As Boolean) chkLisser.Checked = bVal End Set End Property Public Property bPaletteSysteme() As Boolean Get Return chkPaletteSysteme.Checked End Get Set(bVal As Boolean) chkPaletteSysteme.Checked = bVal m_bPaletteModifiee = True End Set End Property Public Property iNbCouleurs%() Get Return CInt(nudNbCouleurs.Value) ' nud : NumericUpDown End Get Set(iVal%) nudNbCouleurs.Value = iVal End Set End Property Public Property iPremCouleur%() Get Return CInt(nudPremCouleur.Value) ' nud : NumericUpDown End Get Set(iVal%) nudPremCouleur.Value = iVal End Set End Property Public Property iNbCyclesDegrade%() Get VerifierPalette() Dim iNbCyclesDegrade0% = CInt(nudNbCyclesDegrade.Value) ' nud : NumericUpDown Return iNbCyclesDegrade0 End Get Set(iVal%) nudNbCyclesDegrade.Value = iVal m_bPaletteModifiee = True End Set End Property Public Property bPaletteAleatoire() As Boolean Get Return chkPaletteAleatoire.Checked End Get Set(bVal As Boolean) chkPaletteAleatoire.Checked = bVal m_bPaletteModifiee = True End Set End Property Public Property iDegre%() Get Return CInt(nudDegre.Value) ' nud : NumericUpDown End Get Set(iVal%) nudDegre.Value = iVal End Set End Property Public Property iNbIterationsMax%() Get Return CInt(nudNbIterationsMax.Value) End Get Set(iVal%) nudNbIterationsMax.Value = iVal End Set End Property Public Property ptfJulia() As PointF Get Return m_ptfJulia End Get Set(rVal As PointF) m_ptfJulia = rVal MajTxtJulia(bLimiterPrecision:=False) pbxJulia.Invalidate() End Set End Property Public Property typeFrac As TFractal Get Return m_typeFract End Get Set(bVal As TFractal) m_typeFract = bVal Select Case bVal Case TFractal.Mandelbrot : rbMandelbrot.Checked = True Case TFractal.Julia : rbJulia.Checked = True Case TFractal.MandelbrotEtJulia : rbMandelbrotEtJulia.Checked = True End Select End Set End Property Public Property bJulia() As Boolean Get Return m_bJulia End Get Set(bVal As Boolean) m_bJulia = bVal End Set End Property Public Property bEffacerImg() As Boolean Get Return chkEffacerImg.Checked ' chk : CheckBox End Get Set(bVal As Boolean) chkEffacerImg.Checked = bVal End Set End Property Public Property bDecimal() As Boolean Get Return chkDecimal.Checked End Get Set(bVal As Boolean) chkDecimal.Checked = bVal End Set End Property Public Property bAlgoRapide() As Boolean Get Return chkAlgoRapide.Checked End Get Set(bVal As Boolean) chkAlgoRapide.Checked = bVal End Set End Property Public WriteOnly Property iAvancement%() Set(iVal%) pbAvancement.Value = Math.Min(iVal, 100) ' pb : ProgressBar End Set End Property Public WriteOnly Property sCoordZoom$() Set(sVal$) lblZoom.Text = sVal ' lbl : Label End Set End Property Public ReadOnly Property bModeDetailIterations() As Boolean Get Return chkModeDetailIterations.Checked End Get End Property Public Property bModeTranslation() As Boolean Get Return chkModeTranslation.Checked End Get Set(bVal As Boolean) chkModeTranslation.Checked = bVal End Set End Property #End Region #Region "Gestion de l'interface" Private Sub Activation() If chkPaletteSysteme.Checked Then nudNbCouleurs.Enabled = True nudPremCouleur.Enabled = True nudNbCyclesDegrade.Enabled = False chkPaletteAleatoire.Enabled = False pbxVerif.Enabled = False Else nudNbCouleurs.Enabled = False nudPremCouleur.Enabled = False nudNbCyclesDegrade.Enabled = True chkPaletteAleatoire.Enabled = True pbxVerif.Enabled = True End If End Sub Private Sub FrmConfig_Closing(sender As Object, e As System.ComponentModel.CancelEventArgs) _ Handles MyBase.Closing ' Ne pas fermer ce formulaire, le cacher seulement e.Cancel = True : Me.Hide() End Sub Private Sub cmdZoomMoins_Click(sender As Object, e As EventArgs) Handles cmdZoomMoins.Click RaiseEvent EvZoomMoins() End Sub Private Sub cmdZoomInit_Click(sender As Object, e As EventArgs) Handles cmdZoomInit.Click RaiseEvent EvZoomInit() End Sub Private Sub cmdAppliquer_Click(sender As Object, e As EventArgs) Handles cmdAppliquer.Click RaiseEvent EvAppliquer() End Sub Private Sub cmdPause_Click(sender As Object, e As EventArgs) Handles cmdPause.Click RaiseEvent EvPause() End Sub Private Sub cmdStop_Click(sender As Object, e As EventArgs) Handles cmdStop.Click RaiseEvent EvStop() End Sub Private Sub pbxJulia_Paint(sender As Object, e As PaintEventArgs) Handles pbxJulia.Paint ' pbx : PictureBox ' Tracer le cercle unitaire Dim iDiamCercleUnitaire% = 2 * pbxJulia.Width \ iAmplitPrmJulia e.Graphics.DrawEllipse(Pens.Red, pbxJulia.Width \ 2 - iDiamCercleUnitaire \ 2, pbxJulia.Height \ 2 - iDiamCercleUnitaire \ 2, iDiamCercleUnitaire, iDiamCercleUnitaire) ' Tracer la cible représentant le paramètre de Julia Const iDiamCercleCible% = 5 e.Graphics.DrawEllipse(Pens.Black, pbxJulia.Width \ 2 + CInt(pbxJulia.Width * m_ptfJulia.X / iAmplitPrmJulia) - iDiamCercleCible \ 2, pbxJulia.Height \ 2 + CInt(pbxJulia.Height * -m_ptfJulia.Y / iAmplitPrmJulia - iDiamCercleCible \ 2), iDiamCercleCible, iDiamCercleCible) End Sub Private Sub pbPrmJulia_MouseDown(sender As Object, e As MouseEventArgs) Handles pbxJulia.MouseDown m_ptfJulia = New PointF( CSng(iAmplitPrmJulia * (e.X - pbxJulia.Width / 2) / pbxJulia.Width), CSng(iAmplitPrmJulia * (-e.Y + pbxJulia.Height / 2) / pbxJulia.Height)) MajTxtJulia(bLimiterPrecision:=True) pbxJulia.Invalidate() End Sub Private Sub MajTxtJulia(bLimiterPrecision As Boolean) Dim sFormat$ = "" If bLimiterPrecision Then sFormat = "0.00" txtJuliaX.Text = m_ptfJulia.X.ToString(sFormat) ' txt : TextBox txtJuliaY.Text = m_ptfJulia.Y.ToString(sFormat) End Sub Private Sub txtJuliaX_TextChanged(sender As Object, e As EventArgs) Handles txtJuliaX.TextChanged If bConvTxtToSng(txtJuliaX.Text, m_ptfJulia.X) Then pbxJulia.Invalidate() End Sub Private Sub txtJuliaY_TextChanged(sender As Object, e As EventArgs) Handles txtJuliaY.TextChanged If bConvTxtToSng(txtJuliaY.Text, m_ptfJulia.Y) Then pbxJulia.Invalidate() End Sub Private Function bConvTxtToSng(sTxt$, ByRef rVal!) As Boolean Try Dim rVal0! = CSng(sTxt) rVal = rVal0 bConvTxtToSng = True Catch End Try End Function Private Sub nudDegre_ValueChanged(sender As Object, e As EventArgs) _ Handles nudDegre.ValueChanged If nudDegre.Value > 2 AndAlso chkAlgoRapide.Checked Then chkAlgoRapide.Checked = False End Sub Private Sub chkDecimal_CheckedChanged(sender As Object, e As EventArgs) _ Handles chkDecimal.CheckedChanged End Sub Private Sub chkAlgoRapide_CheckedChanged(sender As Object, e As EventArgs) _ Handles chkAlgoRapide.CheckedChanged If chkAlgoRapide.Checked AndAlso nudDegre.Value > 2 Then nudDegre.Value = 2 If chkAlgoRapide.Checked AndAlso chkModeDetailIterations.Checked Then chkModeDetailIterations.Checked = False ' Pour le moment il y a encore un bug : mal centré : on désactive 'If chkAlgoRapide.Checked AndAlso rbJulia.Checked Then rbJulia.Checked = False End Sub Private Sub GestionTypeFract() m_bJulia = rbJulia.Checked OrElse rbMandelbrotEtJulia.Checked panelJulia.Enabled = m_bJulia If rbMandelbrot.Checked Then m_typeFract = TFractal.Mandelbrot ElseIf rbJulia.Checked Then m_typeFract = TFractal.Julia ElseIf rbMandelbrotEtJulia.Checked Then m_typeFract = TFractal.MandelbrotEtJulia End If End Sub Private Sub rbMandelbrot_CheckedChanged(sender As Object, e As System.EventArgs) _ Handles rbMandelbrot.CheckedChanged GestionTypeFract() End Sub Private Sub rbJulia_CheckedChanged(sender As Object, e As EventArgs) Handles rbJulia.CheckedChanged GestionTypeFract() End Sub Private Sub rbMandelbrotEtJulia_CheckedChanged(sender As Object, e As EventArgs) _ Handles rbMandelbrotEtJulia.CheckedChanged GestionTypeFract() End Sub Private Sub chkModeDetailIterations_CheckedChanged(sender As Object, e As EventArgs) _ Handles chkModeDetailIterations.CheckedChanged If chkModeDetailIterations.Checked AndAlso chkAlgoRapide.Checked Then chkAlgoRapide.Checked = False If chkModeDetailIterations.Checked Then RaiseEvent EvAppliquer() RaiseEvent EvDetailIterations() End Sub Private Sub chkModeTranslation_CheckedChanged(sender As Object, e As EventArgs) _ Handles chkModeTranslation.CheckedChanged If chkModeTranslation.Checked Then RaiseEvent EvAppliquer() RaiseEvent EvModeTranslation() End Sub Private Sub chkMire_CheckChanged(sender As Object, e As EventArgs) Handles chkMire.CheckedChanged If chkMire.Checked Then RaiseEvent EvAppliquer() End Sub Private Sub chkPaletteSysteme_CheckedChanged(sender As Object, e As EventArgs) _ Handles chkPaletteSysteme.CheckedChanged Activation() m_bPaletteModifiee = True If chkMire.Checked Then RaiseEvent EvAppliquer() End Sub Private Sub nudPremCouleur_ValueChanged(sender As Object, e As EventArgs) _ Handles nudPremCouleur.ValueChanged If chkMire.Checked Then RaiseEvent EvAppliquer() End Sub Private Sub nudNbCouleurs_ValueChanged(sender As Object, e As EventArgs) _ Handles nudNbCouleurs.ValueChanged If chkMire.Checked Then RaiseEvent EvAppliquer() End Sub Private Sub nudNbCyclesDegrade_ValueChanged(sender As Object, e As EventArgs) _ Handles nudNbCyclesDegrade.ValueChanged m_bPaletteModifiee = True VerifierPalette() If chkMire.Checked Then RaiseEvent EvAppliquer() End Sub Private Sub chkPaletteAleatoire_CheckedChanged(sender As Object, e As EventArgs) _ Handles chkPaletteAleatoire.CheckedChanged m_bPaletteModifiee = True If chkMire.Checked Then RaiseEvent EvAppliquer() End Sub Private Sub chkLisser_CheckedChanged(sender As Object, e As EventArgs) _ Handles chkLisser.CheckedChanged End Sub Private Sub chkFrontiereUnie_CheckedChanged(sender As Object, e As EventArgs) _ Handles chkFrontiereUnie.CheckedChanged If Not chkFrontiereUnie.Checked AndAlso chkAlgoRapide.Checked Then chkAlgoRapide.Checked = False End Sub Private Sub VerifierPalette() pbxVerif.Invalidate() End Sub Private Sub pbxVerif_paint(sender As Object, e As PaintEventArgs) Handles pbxVerif.Paint ' pbx : PictureBox Const sTip$ = "L'indicateur est rouge si le nombre des 1024 couleurs n'est pas divisible" & " par le nombre de cycles (jusqu'à 32 cycles), il indique le risque d'avoir des défauts" & " visibles dans la palette." Dim iNbCyclesDegrade% = CInt(nudNbCyclesDegrade.Value) Dim iNbCouleurs% = iNbCouleursPalette \ iNbCyclesDegrade Dim bErrNbZonesPalette As Boolean = CBool(IIf(iNbCyclesDegrade > 32, False, (iNbCouleurs Mod iNbCyclesDegrade) > 0)) If bErrNbZonesPalette Then Dim iReste% = iNbCouleurs Mod iNbCyclesDegrade 'Debug.WriteLine("Reste : " & iReste) ToolTip1.SetToolTip(pbxVerif, sTip & " : 1024\" & iNbCyclesDegrade & "=" & iNbCouleurs & " mod " & iNbCyclesDegrade & " = " & iReste) e.Graphics.FillRectangle(New SolidBrush(Color.Red), 0, 0, pbxVerif.Width, pbxVerif.Height) Else e.Graphics.FillRectangle(New SolidBrush(Color.LimeGreen), 0, 0, pbxVerif.Width, pbxVerif.Height) ToolTip1.SetToolTip(pbxVerif, sTip) End If End Sub #End Region End Class frmFract.vb ' Fractalis : Traceur de fractales de type Mandelbrot et Julia ' ------------------------------------------------------------ ' Fichier FrmFract.vb ' ------------------- ' Conventions de nommage des variables : ' b pour Boolean (booléen vrai ou faux) ' i pour Integer (%) et Short (System.Int16) ' l pour Long : & ' r pour nombre Réel (Single!, Double# ou Decimal : D) ' a pour Array (tableau) : () ' o pour Object (objet ou classe) ' m_ pour variable Membre de la classe (mais pas pour les constantes) Public Class frmFractalis : Inherits Form #Region "Configuration" ' Désactiver pour partir de la zone standard Private Const bDefinirCible As Boolean = False 'True ' 1 560 x 878 : Max. possible WinForm en 16/9 (alors que l'écran est en 1600 x 1900) ' 1 280 x 720 ' Taille parfaite : 16/9 ' https://support.google.com/youtube/answer/1722171?hl=fr Private Const rRatioImg! = 16 / 9 ''4 / 3 '1.5 'Private Const rRatioImg! = 2.0 'Private Const rRatioImg! = 1.0 'Private Const rRatioImg! = 1.5 'Private Const rRatioImg! = 0.5 Private Const iTailleImgDebug% = 480 '1080 Private Const iTailleImgRelease% = 480 '1080 ' Fabriquation d'une vidéo : mettre True ici (et presser v pour interrompre la vidéo) ' ------------------------------------------ Private bVideo As Boolean = False Private Const iNbImg% = 100 Private Const rIncJuliaRe! = 0 Private Const rZoomVideo As Decimal = 0.9995D ' 1D pour désactivé Private Const bDeplacerPtJulia As Boolean = True Private Const sCarFinVideo$ = "v" Private Const sCheminAVI$ = "\Tmp\Test.avi" ' Chemin relatif où doit être créé la vidéo ' Debug de la création vidéo, le cas échéant Private Const bDebugCompress As Boolean = False Private Const iNumImgDepartDebug% = 4500 Private Const bNumeroterImg As Boolean = False ' ------------------------------------------ Private m_vdo As clsVideo Private m_iNumImg% = 0 Private m_sCheminAVI$ = "" Private m_dTpsDebVideo As Date Private bDesactiverRafraichissementPdtVideo As Boolean = bVideo #End Region #Region "Déclarations" ' Déclaration de la feuille de configuration : ' avec la gestion des événements, il faut utiliser As au lieu de = 'Private m_frmConfig = New frmConfig() Private WithEvents m_frmConfig As New frmConfig() #Const iMethodeCalculSimple = 0 #Const iMethodeCalculRemplissage = 1 #Const iMethodeCalculQuadTree = 2 ' il fonctionne bien au centre de Mandelbrot, mais pas à l'extérieur de l'ensemble : il reste des gros pavés #Const iMethodeCalculRapide = 3 #Const iMethodeCalcul = iMethodeCalculRapide '#Const iMethodeCalcul = iMethodeCalculQuadTree '#Const iMethodeCalcul = iMethodeCalculRemplissage '#Const iMethodeCalcul = iMethodeCalculSimple #If iMethodeCalcul = iMethodeCalculSimple Then Private WithEvents m_clsFract As New ClsFract() #ElseIf iMethodeCalcul = iMethodeCalculRemplissage Then Private WithEvents m_clsFract As New ClsFractRemplissage() #ElseIf iMethodeCalcul = iMethodeCalculRapide Then Private WithEvents m_clsFract As New clsFractRapide() #Else Private WithEvents m_clsFract As New ClsFractQuadTreeR() #End If ' Ne pas commencer à tracer si la feuille n'est pas initialisée Private m_bInitApp As Boolean ' Application initialisée ? ' Suspendre le tracé quelque temps pendant le redimensionnement ' (resize) de l'application Private m_bSuspendreTracePdtResize As Boolean Private m_bReTracer As Boolean ' Les paramètres ont changés : retracer Private m_gr As Graphics ' Graphique de la feuille Private m_szTailleEcran As New Size() ' Dimension du tracé en pixels ' Mémorisation pour retracer le bitmap au retour d'une iconisation Private m_szMemTailleEcran As New Size() ' Pour gérer le bitmap de cache (buffering) : c'est 15% + rapide Private m_bmpCache As Bitmap Private m_bTraceEnCours As Boolean ' Coordonnées en pixels dans l'ensemble de Mandelbrot ou Julia Private m_rectCoordPixels As New Rectangle() Private m_sTitreFrm$ #End Region #Region " Windows Form Designer generated code " Public Sub New() MyBase.New() 'This call is required by the Windows Form Designer. InitializeComponent() 'Add any initialization after the InitializeComponent() call DimensionnerFenetre() End Sub 'Form overrides dispose to clean up the component list. Protected Overloads Overrides Sub Dispose(disposing As Boolean) If disposing Then If Not (components Is Nothing) Then components.Dispose() End If End If MyBase.Dispose(disposing) End Sub 'Required by the Windows Form Designer Private components As System.ComponentModel.IContainer 'NOTE: The following procedure is required by the Windows Form Designer 'It can be modified using the Windows Form Designer. 'Do not modify it using the code editor. Friend WithEvents ToolTip1 As System.Windows.Forms.ToolTip Friend WithEvents TimerResize As System.Windows.Forms.Timer Friend WithEvents TimerVideo As System.Windows.Forms.Timer <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent() Me.components = New System.ComponentModel.Container() Dim resources As System.ComponentModel.ComponentResourceManager = New System.ComponentModel.ComponentResourceManager(GetType(frmFractalis)) Me.TimerResize = New System.Windows.Forms.Timer(Me.components) Me.ToolTip1 = New System.Windows.Forms.ToolTip(Me.components) Me.TimerVideo = New System.Windows.Forms.Timer(Me.components) Me.SuspendLayout() ' 'TimerResize ' Me.TimerResize.Interval = 1000 ' 'TimerVideo ' Me.TimerVideo.Interval = 1 ' 'frmFractalis ' Me.AutoScaleBaseSize = New System.Drawing.Size(5, 13) Me.ClientSize = New System.Drawing.Size(392, 392) Me.Icon = CType(resources.GetObject("$this.Icon"), System.Drawing.Icon) Me.Name = "frmFractalis" Me.Text = "Fractalis" Me.ToolTip1.SetToolTip(Me, "Bouton droit pour configurer (v pour vidéo)") Me.ResumeLayout(False) End Sub #End Region #Region "Initialisations" Private Sub DimensionnerFenetre() ' Fonction appellée depuis le constructeur, après InitializeComponent() ' afin de fixer la taille intérieure de la fenêtre (Me.ClientRectangle) ' de façon à ce qu'elle corresponde exactement à la taille du bitmap ' qui va constituer la taille de la vidéo : ratio 16/9 ' avec des tailles standards, par ex.: 1280 x 720 pixels Dim iTailleImg% = iTailleImgRelease If bDebug Then iTailleImg = iTailleImgDebug 'Me.StartPosition = FormStartPosition.CenterScreen 'Me.StartPosition = FormStartPosition.Manual 'Me.Location = New System.Drawing.Point(10, 10) End If Dim iMarge% = 0 'Debug.WriteLine("Taille demandée : " & iTailleImg & " : Ratio demandé = " & rRatioImg) Dim rRatioEcran As Decimal = 0 If rRatioImg >= 1 Then Dim iLargTot% = CInt(iTailleImg * rRatioImg) Dim iInc% = 0 Do ' Augmenter la hauteur jusqu'à la taille voulue Dim memSize As Drawing.Size = Me.Size Me.Size = New System.Drawing.Size(iLargTot + iInc, iTailleImg + iInc) 'Dim x% = Me.ClientRectangle.Width Dim y% = Me.ClientRectangle.Height If y >= iTailleImg Then Exit Do ' On ne peut pas dépasser la taille de l'écran ! If Me.Size = memSize Then Exit Do iInc += 1 Loop While True Do ' Diminuer la largeur jusqu'au ratio voulu Me.Size = New System.Drawing.Size(iLargTot + iInc - iMarge, iTailleImg + iInc) Dim x% = Me.ClientRectangle.Width Dim y% = Me.ClientRectangle.Height rRatioEcran = CDec(x / y) 'Debug.WriteLine(" iMarge=" & iMarge & " : ratio = " & rRatioEcran) If rRatioEcran <= rRatioImg Then Exit Do iMarge += 1 Loop While True Else Dim iHautTot% = CInt(iTailleImg / rRatioImg) Dim iInc% = 0 Do ' Augmenter la largeur jusqu'à la taille voulue Dim memSize As Drawing.Size = Me.Size Me.Size = New System.Drawing.Size(iTailleImg + iInc, iHautTot + iInc) Dim x% = Me.ClientRectangle.Width 'Dim y% = Me.ClientRectangle.Height If x >= iTailleImg Then Exit Do ' On ne peut pas dépasser la taille de l'écran ! If Me.Size = memSize Then Exit Do iInc += 1 Loop While True Do ' Augmenter la hauteur jusqu'au ratio voulu Me.Size = New System.Drawing.Size(iTailleImg + iInc, iHautTot + iInc + iMarge) Dim x% = Me.ClientRectangle.Width Dim y% = Me.ClientRectangle.Height rRatioEcran = CDec(x / y) 'Debug.WriteLine(" iMarge=" & iMarge & " : ratio = " & rRatioEcran) If rRatioEcran <= rRatioImg Then Exit Do iMarge += 1 Loop While True End If 'Debug.WriteLine(Me.ClientRectangle.Width & "x" & Me.ClientRectangle.Height & _ ' " : Ratio = " & rRatioEcran) If bDebug Then 'Me.StartPosition = FormStartPosition.CenterScreen Me.Location = New System.Drawing.Point(100, 100) End If End Sub Private Sub frmFractalis_FormClosing(sender As Object, e As FormClosingEventArgs) _ Handles Me.FormClosing StopTrace() If bVideo AndAlso m_vdo.m_bVideoEnCours AndAlso Not m_vdo.m_bVideoTerminee Then m_vdo.bTerminer() m_iNumImg = iNbImg ' Arreter la vidéo End If End Sub Private Sub frmFractalis_KeyDown(sender As Object, e As KeyEventArgs) Handles Me.KeyDown If Not (e.Alt OrElse e.Control OrElse e.Shift) Then StopTrace() Select Case e.KeyCode Case Keys.Left : m_clsFract.Deplacer(-clsFract.rPetitDeplacement, 0) Case Keys.Right : m_clsFract.Deplacer(clsFract.rPetitDeplacement, 0) Case Keys.Up : m_clsFract.Deplacer(0, -clsFract.rPetitDeplacement) Case Keys.Down : m_clsFract.Deplacer(0, clsFract.rPetitDeplacement) End Select Retracer() Exit Sub End If If e.Control AndAlso Not (e.Alt OrElse e.Shift) Then Select Case e.KeyCode Case Keys.Up : EvZoomPlus(clsFract.rFactPetitZoomPlus) Case Keys.Down : EvZoomMoins(clsFract.rFactPetitZoomMoins) End Select Exit Sub End If If e.Alt AndAlso Not e.Control Then StopTrace() Dim rDep As Decimal = clsFract.rPetitDeplacementJulia If e.Shift Then rDep = clsFract.rTresPetitDeplacementJulia Select Case e.KeyCode Case Keys.Left : m_clsFract.DeplacerPtJulia(-rDep, 0) Case Keys.Right : m_clsFract.DeplacerPtJulia(rDep, 0) ' Déplacer dans l'autre sens, pour être cohérent avec ' le point affiché dans la config. Case Keys.Up : m_clsFract.DeplacerPtJulia(0, rDep) Case Keys.Down : m_clsFract.DeplacerPtJulia(0, -rDep) End Select Retracer() MajJuliaFrmConfig() Exit Sub End If If e.Alt AndAlso e.Control AndAlso Not e.Shift Then StopTrace() m_clsFract.InitPtJulia() Retracer() MajJuliaFrmConfig() Exit Sub End If End Sub Private Sub frmFractalis_KeyPress(sender As Object, e As Windows.Forms.KeyPressEventArgs) Handles Me.KeyPress 'Debug.WriteLine(e.KeyChar) If bVideo AndAlso m_vdo.m_bVideoEnCours AndAlso e.KeyChar = sCarFinVideo Then e.Handled = True If Is64BitProcess() Then MsgBox("Rappel : Pas de vidéo en 64 bits !", MsgBoxStyle.Information, sTitreMsg) If m_vdo.bTerminer() Then Me.Text = m_sTitreFrm & " : vidéo !" '" : vidéo enregistrée." 'Beep(400, 20) End If Exit Sub End If ' Touche entrée : 'If e.KeyChar = Microsoft.VisualBasic.ChrW(Keys.Return) Then ' e.Handled = True ' Exit Sub 'End If End Sub Private Sub frmFractalis_Load(sender As Object, e As EventArgs) Handles MyBase.Load Dim sVersionAppli$ = " - V" & My.Application.Info.Version.Major & "." & My.Application.Info.Version.Minor & My.Application.Info.Version.Build & " (" & sDateVersionAppli & ")" Dim sTxt$ = Me.Text & sVersionAppli If bDebug Then sTxt &= " - Debug" If Is64BitProcess() Then sTxt &= " - 64 bits" Else sTxt &= " - 32 bits" Me.Text = sTxt m_sTitreFrm = sTxt Me.AddOwnedForm(m_frmConfig) ' Gestion de l'iconisation des 2 feuilles End Sub Private Sub frmFractalis_Activated(sender As Object, e As EventArgs) Handles MyBase.Activated If Not m_bInitApp Then If bVideo Then m_vdo = New clsVideo m_sCheminAVI = Application.StartupPath & sCheminAVI ' Création du dossier, le cas échéant Dim sDossier$ = IO.Path.GetDirectoryName(m_sCheminAVI) If Not IO.Directory.Exists(sDossier) Then Dim di As New IO.DirectoryInfo(sDossier) Try di.Create() Catch End Try If Not IO.Directory.Exists(sDossier) Then MsgBox("Impossible de créer le dossier :" & vbLf & sDossier, MsgBoxStyle.Critical, sTitreMsg) Exit Sub End If End If If m_vdo.bInitialiser(m_sCheminAVI) Then m_iNumImg = 1 m_dTpsDebVideo = Now End If End If InitFract() m_bReTracer = True End If m_bInitApp = True ' On est prêt à tracer maintenant m_bSuspendreTracePdtResize = False End Sub Private Sub frmFractalis_FormClosed(sender As Object, e As FormClosedEventArgs) Handles Me.FormClosed LibererRessourceDotNet() ' 25/01/2015 Pb d'instance qui reste longtemps en ram End Sub Private Sub InitFract() m_frmConfig.iDegre = clsFract.iDegreAlgoDef m_frmConfig.iNbIterationsMax = clsFract.iNbIterationsMaxDepartDef m_frmConfig.bJulia = (clsFract.typeFractDef = TFractal.Julia) m_frmConfig.ptfJulia = clsFract.ptfJuliaDef m_frmConfig.bMire = False m_frmConfig.bPaletteSysteme = clsFract.bPaletteSystemeDef m_frmConfig.bPaletteAleatoire = clsFract.bPaletteAleatoireDef m_frmConfig.iNbCouleurs = clsFract.iCouleurMaxDef m_frmConfig.iPremCouleur = clsFract.iPremCouleurDef m_frmConfig.iNbCyclesDegrade = clsFract.iNbCyclesPaletteDef m_frmConfig.bFrontiereUnie = clsFract.bFrontiereUnieDef m_frmConfig.bAlgoRapide = clsFract.bAlgoRapideDef m_frmConfig.bDecimal = clsFract.bDecimalDef m_frmConfig.bLisser = clsFract.bLisserDef m_clsFract.InitConfig() m_frmConfig.bEffacerImg = m_clsFract.m_bEffacerImgDef m_clsFract.m_prmPalette.bPaletteSysteme = m_frmConfig.bPaletteSysteme m_clsFract.m_prmPalette.iNbCouleurs = m_frmConfig.iNbCouleurs m_clsFract.m_prmPalette.iPremCouleur = m_frmConfig.iPremCouleur m_clsFract.m_prmPalette.iNbCyclesDegrade = m_frmConfig.iNbCyclesDegrade m_clsFract.m_prmPalette.bPaletteAleatoire = m_frmConfig.bPaletteAleatoire m_clsFract.m_prmPalette.bFrontiereUnie = m_frmConfig.bFrontiereUnie m_clsFract.m_prmPalette.bLisser = m_frmConfig.bLisser m_clsFract.InitialiserPrmFract() m_clsFract.InitPalette() If bDefinirCible Then InitCible() 'If clsFract.typeFractDef = TFractal.Julia Then ' Dim x% = Me.ClientRectangle.Width ' Dim y% = Me.ClientRectangle.Height ' Dim rRatioEcran# = x / y ' 'Dim rDep! = CSng(-rRatioEcran / 10) ' 'm_clsFract.Deplacer(rDep, 0) ' m_clsFract.Zoomer(clsFract.rZoomDef) 'End If End Sub Private Sub InitCible() Dim X, Y, Z, ZCible As Decimal Dim IMin% X = 0 : Y = 0 : Z = 4 : IMin = 0 'X = 0.3583868675873765381477125472D 'Y = 0.6468847308973626478270010484D 'Z = 0.0003169718035602269918059889D 'IMin = 2280 If bVideo Then Z = 4 : IMin = 0 m_clsFract.ViserPoint(X, Y, Z, IMin, ZCible) m_frmConfig.iNbIterationsMax = IMin + m_clsFract.iNbIterationsMaxDepart m_clsFract.m_bModeCible = True MajCoordZoomFrmConfig() End Sub Private Function bIconisation() As Boolean bIconisation = False ' Iconisation, autre poss.: tester WindowState If Me.ClientSize.Width = 0 And Me.ClientSize.Height = 0 Then bIconisation = True End Function Private Sub frmFractalis_Resize(sender As Object, e As EventArgs) Handles MyBase.Resize If bIconisation() Then GoTo Fin StopTrace() InitialiserGraphique() ' Il faut recréer le graphique ' Retour d'une iconisation If m_szTailleEcran.Width = m_szMemTailleEcran.Width And m_szTailleEcran.Height = m_szMemTailleEcran.Height Then ' Dans ce cas, on peut réafficher le bitmap pendant le thread ! m_bSuspendreTracePdtResize = False ' Pas besoin du timer invalidate dans ce cas If Not m_bReTracer Then Exit Sub End If m_szMemTailleEcran = m_szTailleEcran ' Si l'application est initialisée, on attend que l'utilisateur ' ait finit de redimensionner la feuille avant de recommencer à tracer If m_bInitApp Then Me.TimerResize.Enabled = True Fin: m_bSuspendreTracePdtResize = True End Sub Private Sub TimerResize_Tick(sender As Object, e As EventArgs) Handles TimerResize.Tick Me.TimerResize.Enabled = False m_bSuspendreTracePdtResize = False Retracer() End Sub Private Sub InitialiserGraphique() If bIconisation() Then Exit Sub m_szTailleEcran = Me.ClientSize m_clsFract.szTailleEcran = m_szTailleEcran m_gr = Me.CreateGraphics ' Au retour d'une iconisation, garder le bitmap If m_szTailleEcran.Width <> m_szMemTailleEcran.Width Or m_szTailleEcran.Height <> m_szMemTailleEcran.Height Then m_bmpCache = New Bitmap( m_szTailleEcran.Width, m_szTailleEcran.Height, Imaging.PixelFormat.Format32bppArgb) ' Test frc rapide 07/08/2014 ' Tracer dans le buffer m_clsFract.Gr = Graphics.FromImage(m_bmpCache) End If m_clsFract.RespecterRatioZoneAbs() MajCoordZoomFrmConfig() If bVideo AndAlso Not IsNothing(m_vdo) AndAlso Not String.IsNullOrEmpty(m_sCheminAVI) Then ' Si une vidéo est commencée, la terminer et arreter le mode vidéo If m_vdo.m_bVideoEnCours Then m_vdo.bTerminer() : bVideo = False ' On peut aussi redémmarer le mode vidéo, mais il faut réinit. ' le nbre d'images restantes, le zoom, ... 'If m_vdo.bInitialiser(m_sCheminAVI) Then InitFract() End If End Sub #End Region #Region "Gestion de l'interface" Private Sub frmFractalis_Paint(sender As Object, e As PaintEventArgs) Handles MyBase.Paint If m_frmConfig.bMire() Then AfficherPalette(e) Exit Sub End If RetracerPaint() End Sub Private Sub RetracerPaint() If m_bSuspendreTracePdtResize Then Exit Sub ' Si on a bufferisé et qu'il s'agit d'une simple m.a.j., ' on affiche le bitmap If Not m_clsFract.bQuitterTrace AndAlso (Not m_bReTracer OrElse bTraceEnCours()) Then MajEcranBmpCache() Exit Sub End If StopTrace() If bVideo AndAlso bDeplacerPtJulia Then If m_iNumImg = 1 Then m_clsFract.m_prm.rDeltaAngle = CDec(Math.PI / 1500) '500) m_clsFract.m_prm.rIm = 0.9D m_clsFract.m_prm.rRe = -0.9D Else m_clsFract.ZoomerFacteur(rZoomVideo, bZoomMoins:=False) m_clsFract.m_prm.rIm -= 0.0001D m_clsFract.m_prm.rRe += 0.00005D End If End If If m_frmConfig.bMire() Then Exit Sub ' Pour l'algo. rapide, réafficher d'emblée la précédente image (sauf en mode vidéo) ' il y a parfois un léger scintillement en gris : ' 18/01/2015 Soluce contre le scintillement : retracer directement If Not m_clsFract.bEffacerImg() AndAlso Not bDesactiverRafraichissementPdtVideo Then MajEcranBmpCache() End If ' Ne pas réinit la palette si c'est la palette aléatoire et qu'elle n'a pas été modifiée If Not m_frmConfig.bPaletteSysteme() AndAlso m_frmConfig.bPaletteModifiee() Then m_clsFract.CalculerNbCouleurs() End If If Not m_frmConfig.bPaletteSysteme() AndAlso m_frmConfig.bPaletteModifiee() Then m_clsFract.InitPaletteCalc() MajCoordZoomFrmConfig() m_frmConfig.bPaletteModifiee = False End If Dim dTpsDeb As Date = Now Me.m_bTraceEnCours = True If Not bVideo Then Me.Text = m_sTitreFrm & "..." ' Mode simulation pour debug pb compression sur youtube Dim bSimul As Boolean = False If bDebugCompress AndAlso bVideo Then If m_iNumImg < iNumImgDepartDebug Then ' m_iNumImg > 1 AndAlso bSimul = True m_clsFract.FinTrace() GoTo Suite End If End If m_clsFract.TracerFractDepart(m_bmpCache) Suite: If Not bVideo Then Dim dTpsFin As Date = Now Dim ts As TimeSpan = dTpsFin - dTpsDeb 'Debug.WriteLine("Temps de tracé : " & ts.TotalSeconds.ToString("0.00") & " sec.") Dim sTps$ = "(" & ts.TotalSeconds.ToString("0.000") & " sec.)" Me.Text = m_sTitreFrm & " " & sTps Exit Sub End If If Not m_vdo.m_bVideoTerminee AndAlso m_iNumImg <= iNbImg Then If Not bSimul Then m_vdo.bAjouterImage(m_bmpCache) Dim sAvancement$ = m_iNumImg & "/" & iNbImg Dim dTpsFin As Date = Now Dim ts As TimeSpan = dTpsFin - m_dTpsDebVideo Dim sTps$ = "(" & ts.TotalSeconds.ToString("0.0") & " sec.)" Me.Text = m_sTitreFrm & " : vidéo... " & sAvancement & " " & sTps End If End Sub Private Sub AfficherPalette(e As PaintEventArgs) m_clsFract.CalculerNbCouleurs() If Not m_frmConfig.bPaletteSysteme Then _ m_clsFract.InitPaletteCalc() : m_frmConfig.bPaletteModifiee = False Me.Size = New Size(1500, 850) Dim fs As New FontStyle() Dim font1 As Font = New Font(Me.Font, fs) Dim brushBlanc As New SolidBrush(Color.White) Dim brushNoir As New SolidBrush(Color.Black) Dim brush0 As New SolidBrush(Color.Black) Dim iPas% = 32 '35 Dim iNumPave% = 0 For y As Integer = 0 To Me.Size.Height - iPas Step iPas For x As Integer = 0 To Me.Size.Width - iPas Step iPas Dim couleur As Color = m_clsFract.CouleurPalette(iNumPave, bFrontiere:=False) brush0.Color = couleur e.Graphics.FillRectangle(brush0, x, y, iPas, iPas) Dim sVal$ = iNumPave.ToString e.Graphics.FillRectangle(brushBlanc, x, y, 28, 13) e.Graphics.DrawString(sVal, font1, brushNoir, x, y) iNumPave += 1 Next Next End Sub Private Sub DisplayKnownColors(e As PaintEventArgs) Me.Size = New Size(650, 550) Dim i As Integer ' Get all the values from the KnownColor enumeration. Dim colorsArray As System.Array = [Enum].GetValues(GetType(KnownColor)) Dim allColors(colorsArray.Length) As KnownColor Array.Copy(colorsArray, allColors, colorsArray.Length) ' Loop through printing out the value's name in the colors ' they represent. Dim y As Single Dim x As Single = 10.0F For i = 0 To allColors.Length - 1 ' If x is a multiple of 30, start a new column. If (i > 0 And i Mod 30 = 0) Then x += 105.0F y = 15.0F Else ' Otherwise increment y by 15. y += 15.0F End If ' Create a custom brush from the color and use it to draw ' the brush's name. 'Me.Font.Bold = True Dim fs As New FontStyle() 'fs.Bold = True Dim font1 As Font = New Font(Me.Font, fs) Dim aBrush As New SolidBrush(Color.FromName( allColors(i).ToString())) Dim kc As KnownColor = allColors(i) Dim couleur As Color = Color.FromKnownColor(kc) Dim brush0 As New SolidBrush(couleur) 'Color.Black e.Graphics.FillRectangle(brush0, x - 12, y, 13, 13) e.Graphics.DrawString(allColors(i).ToString(), font1, aBrush, x, y) ' Dispose of the custom brush. aBrush.Dispose() Next End Sub Private Sub MajEcranBmpCache() If bVideo AndAlso bNumeroterImg AndAlso m_iNumImg <= iNbImg Then Dim fs As New FontStyle() Dim font1 As Font = New Font(Me.Font, fs) Dim width% = m_bmpCache.Width Dim heigth% = m_bmpCache.Height Const iMargeHaut% = 30 ' Ne pas mettre 0, car WMP cache le haut de l'img ! Dim rectBmp As New Rectangle(0, iMargeHaut, width, heigth) Dim g As Graphics = Graphics.FromImage(Me.m_bmpCache) g.SmoothingMode = Drawing2D.SmoothingMode.AntiAlias g.InterpolationMode = Drawing2D.InterpolationMode.HighQualityBicubic g.PixelOffsetMode = Drawing2D.PixelOffsetMode.HighQuality g.DrawString(m_iNumImg.ToString, font1, Brushes.White, rectBmp) g.Flush() End If m_gr.DrawImage(m_bmpCache, 0, 0) End Sub Private Sub frmFractalis_Closing(sender As Object, e As _ System.ComponentModel.CancelEventArgs) Handles MyBase.Closing StopTrace() End Sub Private Sub frmFractalis_MouseDown(sender As Object, e As MouseEventArgs) Handles MyBase.MouseDown If e.Button = MouseButtons.Left Then StopTrace() If m_clsFract.bModeDetailIterations Then _ m_clsFract.SelectionnerPoint(New Point(e.X, e.Y)) : Exit Sub m_rectCoordPixels = New Rectangle(e.X, e.Y, 0, 0) End If If e.Button <> MouseButtons.Right Then Exit Sub ' Affichage du panneau de configuration de Fractalis If bTraceEnCours() Then Me.m_clsFract.m_bPause = True ': m_thrdFract.Suspend() ' Note : Pour pouvoir fixer la position de la feuille avant d'appeler ' Show(), il faut que m_frmConfig.StartPosition soit sur manual If Me.WindowState = FormWindowState.Normal Then _ m_frmConfig.Location = New Point(Me.Left + Me.Width, Me.Top) m_frmConfig.Show() MajCoordZoomFrmConfig() If bTraceEnCours() Then ' Petit défaut : il faudrait laisser au formulaire le temps ' de s'afficher, mais le Suspend et le Resume ne suffisent pas 'm_thrdFract.Sleep(1000) ' inutile : ne suffit pas ' Attention au problème de synchronisation avec la mise à jour ' du bitmap : cela provoque parfois un blocage ! 'Application.DoEvents() ' Dans la prochaine version, je vais peut être enlever le thread 'm_thrdFract.Resume() Me.m_clsFract.m_bPause = False End If End Sub Private Sub frmFractalis_MouseMove(sender As Object, e As MouseEventArgs) Handles MyBase.MouseMove If e.Button <> MouseButtons.Left Then Exit Sub If m_clsFract.bModeDetailIterations Then _ m_clsFract.SelectionnerPoint(New Point(e.X, e.Y)) : Exit Sub MajEcranBmpCache() rectTracerSelection(e) End Sub Private Sub frmFractalis_MouseUp(sender As Object, e As MouseEventArgs) Handles MyBase.MouseUp If e.Button <> MouseButtons.Left Then Exit Sub If m_clsFract.bModeDetailIterations Then Exit Sub Dim rectNorm As Rectangle = rectTracerSelection(e) If rectNorm.Width = 0 Or rectNorm.Height = 0 Then Exit Sub m_rectCoordPixels = rectNorm m_clsFract.ZoomerZonePixels(m_rectCoordPixels) Retracer() End Sub Private Function rectTracerSelection(e As MouseEventArgs) As Rectangle ' Tracer le cadre de sélection d'une zone à zoomer et ' renvoyer le rectangle normalisé et recadré selon le ' ratio de l'écran, en pixels ' Idée : utiliser le mode XOR pour ne pas effacer le tracé : ' je n'ai pas trouvé comment faire en VB .NET ' Autre solution : retracer le bitmap de cache avant l'appel ' à cette fonction ' Méthode la plus simple s'il n'y a pas besoin de respecter le ratio 'Dim m_pt2 As New Point(e.X, e.Y) 'm_rectCoordPixels = New Rectangle( _ ' Math.Min(m_pt1.X, m_pt2.X), _ ' Math.Min(m_pt1.Y, m_pt2.Y), _ ' Math.Abs(m_pt2.X - m_pt1.X), _ ' Math.Abs(m_pt2.Y - m_pt1.Y)) m_rectCoordPixels.Width = e.X - m_rectCoordPixels.Left m_rectCoordPixels.Height = e.Y - m_rectCoordPixels.Top Dim rectNorm As Rectangle = m_rectCoordPixels rectNorm = rectRespecterRatioZonePixels(rectNorm) rectNorm = rectNormaliserRectangle(rectNorm) m_gr.DrawRectangle(Pens.Black, rectNorm) rectTracerSelection = rectNorm End Function Private Function rectRespecterRatioZonePixels( rectCoordPixels As Rectangle) As Rectangle ' Attention : la zone de sélection doit être proportionnelle ' au ratio de l'écran If m_szTailleEcran.Height >= m_szTailleEcran.Width Then ' \ : Antislash = Division entière If m_szTailleEcran.Width <> 0 Then _ rectCoordPixels.Height = rectCoordPixels.Width * m_szTailleEcran.Height \ m_szTailleEcran.Width Else If m_szTailleEcran.Height <> 0 Then _ rectCoordPixels.Width = rectCoordPixels.Height * m_szTailleEcran.Width \ m_szTailleEcran.Height End If rectRespecterRatioZonePixels = rectCoordPixels End Function Private Function rectNormaliserRectangle(rect As Rectangle) As Rectangle ' Traiter les rectangles à l'envers rectNormaliserRectangle = rect If rect.Width < 0 And rect.Height < 0 Then rectNormaliserRectangle = New Rectangle( rect.Left + rect.Width, rect.Top + rect.Height, -rect.Width, -rect.Height) Exit Function End If If rect.Width < 0 Then _ rectNormaliserRectangle = New Rectangle( rect.Left + rect.Width, rect.Top, -rect.Width, rect.Height) If rect.Height < 0 Then _ rectNormaliserRectangle = New Rectangle( rect.Left, rect.Top + rect.Height, rect.Width, -rect.Height) End Function Private Sub MajCoordZoomFrmConfig() ' Centre et amplitude du zoom en coordonnées absolues ' 28 décimales : on a besoin du max. de précision 'Const sFormat$ = "0.0000000000000000000000000000" Dim sCoordZoom$ = "Coordonnées du zoom (" & m_clsFract.m_iNbCouleurs & " couleurs) :" sCoordZoom &= vbLf & "X = " & m_clsFract.rCentreX & "D" '.ToString(sFormat) sCoordZoom &= vbLf & "Y = " & m_clsFract.rCentreY & "D" '.ToString(sFormat) sCoordZoom &= vbLf & "Z = " & m_clsFract.rAmplitX & "D" '.ToString(sFormat) Dim rLogAct# = Math.Log10(m_clsFract.rAmplitX) Dim sCible$ = "" Dim sType$ = " dbl" Dim rLimite As Decimal = CDec(clsFract.rAmplitudeMinOkDouble) If m_frmConfig.bDecimal Then rLimite = clsFract.rAmplitudeMinOkDecimal : sType = " dec." Dim rLogLimite# = Math.Log10(rLimite) Dim rPCLimite# = rLogAct / rLogLimite Dim sPCLimite$ = rPCLimite.ToString("0.00%") Dim sLimite$ = "Limite " & sType & " : " & sPCLimite If m_clsFract.m_bModeCible Then Dim rLogCible# = Math.Log10(m_clsFract.m_cf.rZoomCible) Dim rPC# = rLogAct / rLogCible Dim sPC$ = rPC.ToString("0.00%") sCible = ", Cible : " & sPC End If sCoordZoom &= vbLf & sLimite & sCible m_frmConfig.sCoordZoom = sCoordZoom 'sCoordZoom &= vbLf & "IMin = " & m_clsFract.m_iMemNbIterationsMin 'iNbIterationsMin 'sCoordZoom &= vbLf & "IMax = " & m_clsFract.iNbIterationsMax m_frmConfig.iNbIterationsMax = m_clsFract.iNbIterationsMax sCoordZoom &= vbLf & "IMin = " & m_clsFract.iNbIterationsMax sCoordZoom = sCoordZoom.Replace(",", ".") 'Debug.WriteLine("") 'Debug.WriteLine(sCoordZoom) sCoordZoom = sCoordZoom.Replace(vbLf, vbCrLf) If Not bVideo Then CopierPressePapier(sCoordZoom) 'Dim sCoord$ = _ ' "m_clsFract.m_cf.rCoordAbsXMin=" & m_clsFract.m_cf.rCoordAbsXMin & _ ' "D: m_clsFract.m_cf.rCoordAbsXMax=" & m_clsFract.m_cf.rCoordAbsXMax & _ ' "D: m_clsFract.m_cf.rCoordAbsYMin=" & m_clsFract.m_cf.rCoordAbsYMin & _ ' "D: m_clsFract.m_cf.rCoordAbsYMax=" & m_clsFract.m_cf.rCoordAbsYMax & "D" 'sCoord = sCoord.Replace(",", ".") 'Debug.WriteLine("") 'Debug.WriteLine(sCoord) End Sub Private Sub MajJuliaFrmConfig() Dim ptfJulia As New PointF(m_clsFract.rLirePointJuliaX, m_clsFract.rLirePointJuliaY) m_frmConfig.ptfJulia = ptfJulia End Sub Public Sub LireConfig() StopTrace() ' Si les paramètres ont changés, réinitaliser le nombre d'itération Dim bInit As Boolean = False If m_frmConfig.bJulia <> m_clsFract.bJulia Then bInit = True If m_frmConfig.bJulia And (m_frmConfig.ptfJulia.X <> m_clsFract.ptfJulia.X Or m_frmConfig.ptfJulia.Y <> m_clsFract.ptfJulia.Y) Then bInit = True If m_frmConfig.iDegre <> m_clsFract.iDegre Then bInit = True ' Pour m_clsFract.m_iNbIterationsMin = 0 If bInit Then m_clsFract.InitialiserIterations() m_clsFract.typeFrac = m_frmConfig.typeFrac ' Pas utilisé : à vérifier m_clsFract.bJulia = m_frmConfig.bJulia If m_frmConfig.bJulia Then m_clsFract.ptfJulia = m_frmConfig.ptfJulia m_clsFract.iDegre = m_frmConfig.iDegre m_clsFract.iNbIterationsMaxDepart = m_frmConfig.iNbIterationsMax m_clsFract.bEffacerImg = m_frmConfig.bEffacerImg m_clsFract.bModeDetailIterations = m_frmConfig.bModeDetailIterations m_clsFract.bModeTranslation = m_frmConfig.bModeTranslation m_clsFract.m_bAlgoRapide = m_frmConfig.bAlgoRapide m_clsFract.m_bDecimal = m_frmConfig.bDecimal m_clsFract.m_bLisser = m_frmConfig.bLisser m_clsFract.m_prmPalette.bPaletteSysteme = m_frmConfig.bPaletteSysteme m_clsFract.m_prmPalette.iNbCouleurs = m_frmConfig.iNbCouleurs m_clsFract.m_prmPalette.iPremCouleur = m_frmConfig.iPremCouleur m_clsFract.m_prmPalette.iNbCyclesDegrade = m_frmConfig.iNbCyclesDegrade m_clsFract.m_prmPalette.bPaletteAleatoire = m_frmConfig.bPaletteAleatoire m_clsFract.m_prmPalette.bFrontiereUnie = m_frmConfig.bFrontiereUnie m_clsFract.m_prmPalette.bLisser = m_frmConfig.bLisser m_clsFract.CalculerNbCouleurs() If Not m_clsFract.m_prmPalette.bPaletteSysteme Then m_clsFract.InitPaletteCalc() m_clsFract.InitPalette() End Sub Public Sub Retracer() m_bReTracer = True If bVideo Then Me.TimerVideo.Enabled = True Me.TimerVideo.Start() Else ' 18/01/2015 Retracer directement : mode navigation RetracerPaint() End If MajCoordZoomFrmConfig() End Sub Private Sub TimerVideo_Tick(sender As Object, e As EventArgs) Handles TimerVideo.Tick Me.TimerVideo.Stop() RetracerPaint() End Sub Public Sub PauseReprendreTrace() ' Faire une pause du thread ou bien reprendre le thread suspendu If Not bTraceEnCours() Then Exit Sub Me.m_clsFract.m_bPause = Not Me.m_clsFract.m_bPause End Sub Public Sub StopTrace() If Not bTraceEnCours() Then Exit Sub m_clsFract.bQuitterTrace = True m_frmConfig.iAvancement = 0 m_clsFract.bModeDetailIterations = m_frmConfig.bModeDetailIterations m_clsFract.bModeTranslation = m_frmConfig.bModeTranslation Me.m_bTraceEnCours = False End Sub Public Function bTraceEnCours() As Boolean Return Me.m_bTraceEnCours End Function #End Region #Region "Gestion des événements particuliers" Private Sub m_frmConfig_EvAppliquer() Handles m_frmConfig.EvAppliquer LireConfig() If m_frmConfig.bMire() Then Invalidate() Exit Sub End If Retracer() End Sub Private Sub m_frmConfig_EvPause() Handles m_frmConfig.EvPause PauseReprendreTrace() End Sub Private Sub m_frmConfig_EvStop() Handles m_frmConfig.EvStop StopTrace() m_iNumImg = iNbImg ' Arreter la vidéo End Sub Private Sub m_frmConfig_EvZoomInit() Handles m_frmConfig.EvZoomInit StopTrace() m_clsFract.InitialiserPrmFract() LireConfig() Retracer() End Sub Private Sub m_frmConfig_EvZoomMoins() Handles m_frmConfig.EvZoomMoins EvZoomMoins(clsFract.rFacteurZoomMoins) End Sub Private Sub EvZoomPlus(rFacteurZoomPlus As Decimal) StopTrace() m_clsFract.ZoomerFacteur(rFacteurZoomPlus, bZoomMoins:=False) Retracer() End Sub Private Sub EvZoomMoins(rFacteurZoomMoins As Decimal) StopTrace() ' 21/08/2014 Avant de réinit. le nombre d'itération min. ' d'abord augmenter le nombre d'itération de départ m_clsFract.iNbIterationsMaxDepart = m_clsFract.iNbIterationsMax m_clsFract.InitialiserIterations() ' Ne pas utiliser le zoom fenêtre (pour éviter de modifier la position actuelle) : 'm_clsFract.Zoomer(rFacteurZoomPlus) ' Mais le zoom depuis la position actuelle m_clsFract.ZoomerFacteur(rFacteurZoomMoins, bZoomMoins:=True) Retracer() End Sub Private Sub m_clsFract_EvMajBmp() Handles m_clsFract.EvMajBmp MajEcranBmpCache() End Sub Private Sub m_frmConfig_EvModeTranslation() Handles m_frmConfig.EvModeTranslation m_clsFract.bModeTranslation = m_frmConfig.bModeTranslation If Not m_clsFract.bModeTranslation Then MajEcranBmpCache() End Sub Private Sub m_frmConfig_EvDetailIterations() Handles m_frmConfig.EvDetailIterations m_clsFract.bModeDetailIterations = m_frmConfig.bModeDetailIterations If Not m_clsFract.bModeDetailIterations Then MajEcranBmpCache() End Sub Private Sub m_clsFract_EvDetailIterations(aPt() As Drawing.Point) Handles m_clsFract.EvDetailIterations If IsNothing(aPt) Then Exit Sub MajEcranBmpCache() Const iEpaisseurTrait% = 2 Dim penBlanc As New Pen(Color.White, iEpaisseurTrait) For i As Integer = 1 To aPt.GetUpperBound(0) m_gr.DrawLine(penBlanc, aPt(i - 1), aPt(i)) Next i End Sub Private Sub m_clsFract_EvMajAvancement(iAvancement%) Handles m_clsFract.EvMajAvancement m_frmConfig.iAvancement = iAvancement End Sub Private Sub m_clsFract_EvFinTrace() Handles m_clsFract.EvFinTrace m_bReTracer = False m_frmConfig.iAvancement = 0 m_clsFract.bModeDetailIterations = m_frmConfig.bModeDetailIterations m_clsFract.bModeTranslation = m_frmConfig.bModeTranslation If Not m_clsFract.m_bQuitterTrace Then If bVideo Then m_iNumImg += 1 ' Rajouter une image à la fin pour avoir le bon compte dans la vidéo 28/03/2015 If m_iNumImg <= iNbImg + 1 Then Me.m_bTraceEnCours = False Retracer() If bDeplacerPtJulia Then MajJuliaFrmConfig() Exit Sub End If End If Dim W As Decimal = m_clsFract.m_cf.rCoordAbsXMax - m_clsFract.m_cf.rCoordAbsXMin Dim H As Decimal = m_clsFract.m_cf.rCoordAbsYMax - m_clsFract.m_cf.rCoordAbsYMin ' Ne marche pas : on n'obtient pas exactement le même point de zoom ' (il faudrait commencer en décimal, mais 20x + lent) 'Const rPaveMin3# = 0.00000000000002 ' 2E-14 'Const rPaveMin2# = 0.0000000000001 ' 1E-13 'Const rPaveMin1# = 0.0000000000005 ' 5E-13 'Const rPaveMin1# = 0.000000000002 ' 1E-12 Dim rPaveMin3 As Decimal = CDec(clsFract.rAmplitudeMinOkDouble) If m_frmConfig.bDecimal Then rPaveMin3 = clsFract.rAmplitudeMinOkDecimal Dim rPaveMin2 As Decimal = rPaveMin3 * 5 Dim rPaveMin1 As Decimal = rPaveMin2 * 5 Dim iFreqBeep% = 600 Dim iDuree% = 20 If W < rPaveMin3 OrElse H < rPaveMin3 Then iFreqBeep = 200 : iDuree = 50 ElseIf W < rPaveMin2 OrElse H < rPaveMin2 Then iFreqBeep = 400 ElseIf W < rPaveMin1 OrElse H < rPaveMin1 Then iFreqBeep = 500 End If Beep(iFreqBeep, iDuree) End If End Sub #End Region End Class modUtil.vb Module modUtil Public m_sTitreMsg$ = sTitreMsg Public Sub AfficherMsgErreur2(ByRef Ex As Exception, Optional sTitreFct$ = "", Optional sInfo$ = "", Optional sDetailMsgErr$ = "", Optional bCopierMsgPressePapier As Boolean = True, Optional ByRef sMsgErrFinal$ = "") If Not Cursor.Current.Equals(Cursors.Default) Then _ Cursor.Current = Cursors.Default Dim sMsg$ = "" If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg &= vbCrLf & sInfo If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr If Ex.Message <> "" Then sMsg &= vbCrLf & Ex.Message.Trim If Not IsNothing(Ex.InnerException) Then _ sMsg &= vbCrLf & Ex.InnerException.Message End If If bCopierMsgPressePapier Then CopierPressePapier(sMsg) sMsgErrFinal = sMsg MsgBox(sMsg, MsgBoxStyle.Critical) End Sub Public Sub CopierPressePapier(sInfo$) ' Copier des informations dans le presse-papier de Windows ' (elles resteront jusqu'à ce que l'application soit fermée) Try Dim dataObj As New DataObject dataObj.SetData(DataFormats.Text, sInfo) Clipboard.SetDataObject(dataObj) Catch ex As Exception ' Le presse-papier peut être indisponible AfficherMsgErreur2(ex, "CopierPressePapier", bCopierMsgPressePapier:=False) End Try End Sub Public Function Is64BitProcess() As Boolean Return (IntPtr.Size = 8) End Function Public Sub LibererRessourceDotNet() ' 19/01/2011 Il faut appeler 2x : ' cf. All-In-One Code Framework\Visual Studio 2008\VBAutomateWord ' Clean up the unmanaged Word COM resources by forcing a garbage ' collection as soon as the calling function is off the stack (at ' which point these objects are no longer rooted). GC.Collect() GC.WaitForPendingFinalizers() ' GC needs to be called twice in order to get the Finalizers called ' - the first time in, it simply makes a list of what is to be ' finalized, the second time in, it actually the finalizing. Only ' then will the object do its automatic ReleaseComObject. GC.Collect() GC.WaitForPendingFinalizers() TraiterMsgSysteme_DoEvents() End Sub Public Sub TraiterMsgSysteme_DoEvents() 'Try Application.DoEvents() ' Peut planter avec OWC : Try Catch nécessaire 'Threading.Thread.Sleep(0) ' Pas totalement équivalent à DoEvents() 'Catch 'End Try End Sub Public Function bFichierExiste(sCheminFichier$, Optional bPrompt As Boolean = False) As Boolean ' Retourne True si un fichier correspondant est trouvé ' Ne fonctionne pas avec un filtre, par ex. du type C:\*.txt Dim bFichierExiste0 As Boolean = IO.File.Exists(sCheminFichier) If Not bFichierExiste0 AndAlso bPrompt Then _ MsgBox("Impossible de trouver le fichier :" & vbLf & sCheminFichier, MsgBoxStyle.Critical, m_sTitreMsg & " - Fichier introuvable") Return bFichierExiste0 End Function Public Const sCauseErrPoss$ = "Le fichier est peut-être protégé en écriture ou bien verrouillé par une autre application" Public Const sCauseErrPossDossier$ = "Le dossier est peut-être protégé en écriture" & vbLf & "ou bien un fichier est verrouillé par une autre application" ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception <System.Diagnostics.DebuggerStepThrough()> Public Function bFichierAccessible(sCheminFichier$, Optional bPrompt As Boolean = False, Optional bPromptFermer As Boolean = False, Optional bInexistOk As Boolean = False, Optional bPromptRetenter As Boolean = False, Optional bLectureSeule As Boolean = False, Optional bEcriture As Boolean = True) As Boolean ' Vérifier si un fichier est accessible en écriture (non verrouillé par Excel par exemple) ' bEcriture = True par défaut (pour la rétrocompatibilité de la fct bFichierAccessible) ' Nouveau : Simple lecture : Mettre bEcriture = False ' On conserve l'option bLectureSeule pour alerter qu'un fichier doit être fermé ' par l'utilisateur (par exemple un classeur Excel ouvert) bFichierAccessible = False If bInexistOk Then ' Avec cette option, ne pas renvoyer Faux si le fichier n'existe pas If Not bFichierExiste(sCheminFichier) Then ' Et ne pas alerter non plus bFichierAccessible = True Exit Function End If Else If Not bFichierExiste(sCheminFichier, bPrompt) Then Exit Function End If End If Retenter: Dim reponse As MsgBoxResult = MsgBoxResult.Cancel Try ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim mode As IO.FileMode = IO.FileMode.Open Dim access As IO.FileAccess = IO.FileAccess.ReadWrite If Not bEcriture Then access = IO.FileAccess.Read Using fs As New IO.FileStream(sCheminFichier, mode, access, IO.FileShare.ReadWrite) fs.Close() End Using bFichierAccessible = True Catch ex As Exception Dim msgbs As MsgBoxStyle = MsgBoxStyle.Exclamation If bPrompt Then AfficherMsgErreur2(ex, "bFichierAccessible", "Impossible d'accéder au fichier :" & vbLf & sCheminFichier, sCauseErrPoss) ElseIf bPromptFermer Then Dim sQuestion$ = "" If bPromptRetenter Then msgbs = msgbs Or MsgBoxStyle.RetryCancel sQuestion = vbLf & "Voulez-vous réessayer ?" End If ' Attention : le fichier peut aussi être en lecture seule pour diverses raisons ! ' Certains fichiers peuvent aussi être inaccessibles pour une simple lecture ' par ex. certains fichiers du dossier ' \Documents and Settings\All Users\Application Data\Microsoft\Crypto\RSA\MachineKeys\ If bLectureSeule Then ' Le verrouillage Excel peut ralentir une lecture ODBC, ' mais sinon la lecture directe n'est pas possible, même avec ' IO.FileMode.Open, IO.FileAccess.Read et IO.FileShare.Read ? ' (sauf si le fichier a l'attribut lecture seule) ' En fait si, à condition de préciser IO.FileShare.ReadWrite reponse = MsgBox( "Veuillez fermer S.V.P. le fichier :" & vbLf & sCheminFichier & sQuestion, msgbs, m_sTitreMsg) Else reponse = MsgBox("Le fichier n'est pas accessible en écriture :" & vbLf & sCheminFichier & vbLf & "Le cas échéant, veuillez le fermer, ou bien changer" & vbLf & "ses attributs de protection, ou alors les droits d'accès." & sQuestion, msgbs, m_sTitreMsg) End If End If End Try If Not bFichierAccessible And reponse = MsgBoxResult.Retry Then GoTo Retenter End Function Public Function bSupprimerFichier(sCheminFichier$, Optional bPromptErr As Boolean = False) As Boolean ' Vérifier si le fichier existe If Not bFichierExiste(sCheminFichier) Then Return True If Not bFichierAccessible(sCheminFichier, bPromptFermer:=bPromptErr, bPromptRetenter:=bPromptErr) Then Return False ' Supprimer le fichier Try IO.File.Delete(sCheminFichier) Return True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "Impossible de supprimer le fichier :" & vbLf & sCheminFichier, sCauseErrPoss) Return False End Try End Function #Region "Rnd" Private Const bRndClassique As Boolean = False Public Sub InitRnd() ' 20/11/2011 Utile seulement avec bRndClassique If bRndClassique Then VBMath.Randomize() End Sub Public Function iRandomiser%(iMin%, iMax%) Dim iRes As Integer = 0 If iMin = iMax Then Return iMin Dim rRnd! If bRndClassique Then rRnd = VBMath.Rnd() Else Static rRndGenerateur As New Random Dim rRndDouble As Double = rRndGenerateur.NextDouble rRnd = CSng(rRndDouble) 'rRnd = 1 End If ' On atteint jamais la borne max. 'Dim rVal! = iMin + rRnd * (iMax - iMin) ' 13/11/2011 Dim rVal! = iMin + rRnd * (iMax + 1 - iMin) ' Fix : Partie entière sans arrondir à l'entier le plus proche iRes = iFix(rVal) ' Au cas où Rnd() renverrait 1.0 et qq If iRes > iMax Then iRes = iMax 'Debug.WriteLine("Tirage entier entre " & iMin & " et " & iMax & " = " & iRes) Return iRes End Function #End Region Public Function iFix%(rVal!) ' Fix : Partie entière sans arrondir à l'entier le plus proche iFix = CInt(IIf(rVal > 0, Math.Floor(rVal), Math.Ceiling(rVal))) End Function End Module