mandelbrot

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
dafhi
Posts: 1329
Joined: Jun 04, 2005 9:51

mandelbrot

Postby dafhi » Oct 20, 2011 1:26

Smooth color mandelbrot with color cycling.
Lets you save a .bmp twice as big as viewport. Note: alpha channel with .bmp only visible in a handful of editors / viewers.

- UPDATES -
Jan 23 - code clarifications and general improvement
Jan 17 - A quick update to improve visibility during initial calculation

Code: Select all

#Include "fbgfx.bi"

#If __FB_LANG__ = "fb"
Using fb
#EndIf

Dim Shared As Integer              SCR_W = 784
Dim Shared As Integer              SCR_H = 588

Dim Shared As Integer              Iterations = 70
Dim Shared As UInteger             bmpfileScale = 2

'' huge saved bmp and render time awareness
Const                              BMP_SCALE_PROTOCOL = 4

If bmpfileScale < 1 Then bmpfileScale = 1
If bmpfileScale > BMP_SCALE_PROTOCOL Then bmpfileScale = BMP_SCALE_PROTOCOL

Dim Shared As Integer              WidM: WidM = SCR_W - 1
Dim Shared As Integer              HgtM: HgtM = SCR_H - 1
Dim Shared As Integer              X,Y, mpitch

Dim e As EVENT

ScreenRes SCR_W,SCR_H,32,, fb.GFX_ALPHA_PRIMITIVES
ScreenInfo x,,,,mpitch

Dim Shared As Double               SCR_DIAGONAL:SCR_DIAGONAL = Sqr(SCR_W^2+SCR_H^2)

Type ImageInfo
   As Any ptr                      img,pixels
   As Integer                      pitch,wid,hgt,pitchV2,widM,hgtM
   Declare Sub Create(ByVal pWid As UShort=SCR_W,ByVal pHgt As UShort=SCR_H,ByVal pRed As UByte=205,ByVal pGrn As UByte=205,ByVal pBlu As UByte=205,ByVal pAph As UByte=255)
   Declare Sub Fill(ByVal pCol As UInteger)
   Declare Sub Destroy
End Type

Type hMap
   As Long                         PalEntry
End Type

Dim Shared As ImageInfo            img_B,img_F,img_HiRes,img_Load
Dim Shared As hMap                 hMap_WndRes(WidM,HgtM), hMap_HiRes()

img_HiRes.Create(bmpfileScale*SCR_W, bmpfileScale*SCR_H)
ReDim hMap_HiRes(bmpfileScale*SCR_W-1, bmpfileScale*SCR_H-1)

#Macro StatusUpdate(Y)
   Line (0,0)-(24,8),RGBA(255,255,255,255),bf
   Draw String (0, 0), Str(Int(100 * Y / pHiRes.hgtM)) & "%", RGBA(0,128,0,255)
#EndMacro

Sub ImageInfo.Create(ByVal pWid As UShort,ByVal pHgt As UShort,ByVal pRed As UByte,ByVal pGrn As UByte,ByVal pBlu As UByte,ByVal pAph As UByte)
   img = ImageCreate( pWid, pHgt, RGBA(pRed,pGrn,pBlu,pAph))
   wid = pWid
   hgt = pHgt
   ImageInfo img, ,,, pitch, pixels
   pitchV2 = pitch \ 4
   widM = wid - 1
   hgtM = hgt - 1
End Sub
Sub ImageInfo.Fill(ByVal pCol As UInteger)
   If hgt < 1 Then Exit Sub
Dim As UInteger Ptr destL, dest
   destL = pixels
   For y_ As Integer = 0 To HgtM
      dest = destL
      For x_ As Integer = 0 To WidM
         *dest = pCOL
         dest += 1
      Next
      destL += pitchV2
   Next
End Sub
Sub ImageInfo.Destroy()
   ImageDestroy img
End Sub

Sub CheckerBackground(ByRef pInfo As ImageInfo,ByVal CheckerSize As UInteger = 12,ByVal pColor As UInteger=RGBA(145,145,145,255),ByVal pWidM As Integer=WidM,ByVal pHgtM As Integer=HgtM)
   Dim As UInteger SizeDouble=CheckerSize*2,SizeM=CheckerSize-1
   For Y = 0 To pHgtM Step CheckerSize
      For X = -CheckerSize * ((Y/SizeDouble)=Int(Y/SizeDouble)) To pWidM Step SizeDouble
         Line pInfo.img,(X,Y)-(X+SizeM,Y+SizeM),pColor,BF
      Next
   Next
End Sub

#Ifndef TRUE
#Define TRUE -1
#EndIf
#Ifndef FALSE
#Define FALSE 0
#EndIf
#Ifndef NULL
#Define NULL 0
#EndIf

Dim Shared As Single               SuperSample = 58
Dim Shared As Integer              PaletteSize: PaletteSize = 120 * SuperSample
Dim Shared As UInteger             mPalette(PaletteSize)
Dim Shared As Single               gradient_R()
Dim Shared As Single               gradient_G()
Dim Shared As Single               gradient_B()
Dim Shared As Single               gradient_A1()
Dim Shared As Single               gradient_A2()
Dim Shared As Single               gradient_MaxA()
Dim Shared As Single               m_sng

'' ================================================= ''
''                                                   ''
''             Float-To-Int Begin                    ''
''                                                   ''

''http://www.freebasic.net/forum/viewtopic.php?p=61669&sid=bdfb24167fc808b6e6821ff1fb10cd31

#macro SCW(i)
  asm
  sub esp,2
  fnstcw    [esp]
  mov   ax, [esp]
  and   ax, &HF3FF
  or    ax, &H0400
  mov   [i],ax
  fldcw [i]
#EndMacro

#Macro RCW()
  fldcw [esp]
  add   esp, 2
  end asm
#endmacro

#macro CIntF(i,f)
  asm fld   dword ptr [f]
  asm fistp dword ptr [i]
#endmacro
#Macro FloorF(i,d)
  SCW(i)
  fld   dword ptr [d]
  fistp dword ptr [i]
  RCW()
#EndMacro
''                                               ''
''             Float-To-Int End                  ''
'' ============================================= ''

'' ================================================= ''
''                                                   ''
''             Gradientizer Begin                    ''
''                                                   ''
''                                                   ''
Type GradientRibbon
   As UShort                     Sections
   As UShort                     widBase,widVari
   As Single                     UBPix
   As Single                     Shatter
End Type
Type zAnimProperties
   As Single                     x1,x2,A0,A1,iA0,iA1,tile,xStep,rotRadi
End type

Type ComponentAnimProps
   As Single                     clipLo,clipHi,alphaLo,alphaHi
   As GradientRibbon             infoRibbon
   As zAnimProperties            tile
End Type

Dim Shared As UShort             mWidth()
Dim Shared As Byte               mShatter()
Dim Shared As Single             m_yStart()
Dim Shared As Single             m_yEnd()
Dim Shared As Single             mStart,mSng,mStep,mDelta
Dim Shared As Integer            mX1,mX2
Dim Shared As UInteger           mPalUB_, Tmp__, mAlpha

#Macro zPieceVal(Valu)
   Valu = alphaLo + Rnd * (alphaHi-alphaLo)
#EndMacro
#Macro zComponent_Start_PrvEnd(I_,mX1_)
   zPieceVal(mSng)
   m_yStart(I_) = mSng
   If mShatter(mX1_) Then
      zPieceVal(m_yEnd(mX1_))
   Else
      m_yEnd(mX1_) = m_yStart(I_)
   EndIf
   mX1_ = I_
#EndMacro
Sub zDefComp_retval(ByRef retVal As Single)
   retVal = mSng
   mX1 += 1
   mSng += mStep
End Sub
Sub Pal_AnimProperties(ByRef pComp As ComponentAnimProps,ByVal incAngle1 As Single = 0.003,ByVal incAngle2 As Single = 0.007, ByVal pTile As Single=2.1*(0.1 + Rnd),ByVal rotRadius As Single = 0.36,ByVal clipHi As Single = 0,ByVal clipLo As Single = 0)
   pComp.tile.a0 = Rnd * 6.28
   pComp.tile.a1 = Rnd * 6.28
   pComp.tile.iA0 = incAngle1
   pComp.tile.iA1 = incAngle2
   pComp.tile.rotRadi = rotRadius * pTile
   pComp.clipHi = clipHi
   pComp.clipLo = clipLo
End Sub
Sub DefComponent(ByRef pComp As ComponentAnimProps,ByRef pRibbon As GradientRibbon, retGradient() As Single,ByVal alphaHi As Single = 1, ByVal alphaLo As Single = 0,ByVal incAngle1 As Single = 0.003,ByVal incAngle2 As Single = 0.007,ByVal  pTile As Single=2.1*(0.1 + Rnd),ByVal rotRadius As Single = 0.36,ByVal ClipHi As Single = 0,ByVal ClipLo As Single = 0)
   mX1 = 1
   For I As Integer = 2 To pRibbon.Sections
      zComponent_Start_PrvEnd(I,mX1)
   Next
   zComponent_Start_PrvEnd(1,mX1)
   mX1 = 0
   If UBound(retGradient) <> pRibbon.UBPix Then ReDim retGradient(pRibbon.UBPix)
   For J As Integer = 1 To pRibbon.Sections
      mSng = m_yStart(J)
      mStep = ( m_yEnd(J) - m_yStart(J) ) / mWidth(J)
      zDefComp_retval retGradient(mX1)
      For K As Integer = mX1 To mX1 + ( mWidth(J) - 2 )
         zDefComp_retval retGradient(K)
      Next
   Next
   retGradient(pRibbon.UBPix)=retGradient(0)
   Pal_AnimProperties pComp,incAngle1,incAngle2,pTile,rotRadius,clipHi,clipLo
   pComp.alphaHi = alphaHi
   pComp.alphaLo = alphaLo
   pComp.infoRibbon = pRibbon
End Sub
Sub Gradient(ByRef retINFO As GradientRibbon,ByVal WidBase As UShort = 2,ByVal WidVari As UShort = 50,ByVal Sections As UByte=5+Rnd*15,ByVal Shatter As UByte=0)
   retInfo.Sections = Sections
   ReDim m_yStart(Sections)
   ReDim m_yEnd(Sections)
   ReDim mShatter(Sections)
   ReDim mWidth(Sections)
   retINFO.UBPix = 0
   For I As Integer = 1 To Sections
      mWidth(I) = widBase + Rnd * widVari
      mShatter(I) = Rnd * 255 < Shatter
      retINFO.UBPix += mWidth(I)
   Next
   retINFO.Shatter = Shatter
End Sub
''                                           ''
''            Gradientizer End               ''
'' ========================================= ''

'' ========================================== ''
''                                            ''
''         Custom 5 Gradients Begin           ''
''                                            ''
''                                            ''
Dim Shared As GradientRibbon       mGInfo
Dim Shared As ComponentAnimProps   PS_R,PS_G,PS_B,PS_A1,PS_A2
Dim Shared As Integer              DoRewind = FALSE, AnimColor = TRUE, AnimAlpha = TRUE, MaxAlpha = FALSE
Private sub zStretchPan(ByRef pRibbon As ComponentAnimProps,pGradient() As Single,ByVal pSng As Single,ByVal DoIncrement As Integer,ByVal DefaultCase As Integer)
Dim As Integer Rewind_ = 2 * DoRewind + 1
   pRibbon.tile.x1 = (pRibbon.tile.rotRadi * Sin(pRibbon.tile.A0)) * pRibbon.infoRibbon.UBPix
   pRibbon.tile.x2 = (pRibbon.tile.tile + pRibbon.tile.rotRadi * Cos(pRibbon.tile.A1)) * pRibbon.infoRibbon.UBPix
   If DoIncrement Then
      pRibbon.tile.A0 += pRibbon.tile.iA0 * Rewind_
      pRibbon.tile.A1 += pRibbon.tile.iA1 * Rewind_
   End If
   pRibbon.tile.xStep = (pRibbon.tile.x2 - pRibbon.tile.x1) * pSng
   If pRibbon.clipLo = pRibbon.clipHi Then
      pRibbon.clipHi = pRibbon.alphaHi
      pRibbon.clipLo = pRibbon.alphaLo
   EndIf
End Sub
#Macro zRGBAA_PaletteStream_FourCommonComponents(pS1,pS2,pS3,pS4,sS1,sS2,sS3,sS4,Def1,Def2,Def3,Def4)

   if UBound(pPalette) < 2 then redim pPalette(255)
   mPalUB_ = UBound(pPalette)
   
Dim As Single   in_by_ub_S
Dim As Single   in_by_ub
Dim As Single   l_sng_A
Dim As Single   l_sng_,sng1,sng2
Dim As Integer   int_lo,int_hi

   sng1 = 1 / mPalUB_

   zStretchPan pS1,sS1(),sng1,AnimColor * -DoIncrement,Def1
   zStretchPan pS2,sS2(),sng1,AnimColor * -DoIncrement,Def2
   zStretchPan pS3,sS3(),sng1,AnimColor * -DoIncrement,Def3
   zStretchPan pS4,sS4(),sng1,AnimAlpha * -DoIncrement,Def4

#EndMacro
#Macro zClip(retVal,clipLo,clipHi)
   If retVal > clipHi Then
      retVal = clipHi
   ElseIf RetVal < clipLo Then
      retVal = clipLo
   End if
#EndMacro
#Macro zPaletteStream_Component(p_ret,pComp,pG)
   l_sng_A = pComp.tile.x1
   If l_sng_A >= pComp.InfoRibbon.UBPix Then
      in_by_ub_S = l_sng_A: in_by_uB_S /= pComp.InfoRibbon.UBPix
      in_by_ub = in_by_uB_S
      FloorF(int_lo,in_by_ub)
      l_sng_A -= pComp.InfoRibbon.UBPix * int_lo
   ElseIf l_sng_A < 0 Then
      in_by_ub_S = l_sng_A: in_by_uB_S /= pComp.InfoRibbon.UBPix
      in_by_ub = in_by_uB_S
      FloorF(int_lo,in_by_ub)
      l_sng_A -= pComp.InfoRibbon.UBPix * int_lo
   End If
   FloorF(int_lo,l_sng_A)
   int_hi = int_lo + 1
   l_sng_A = pG(int_lo) + (l_sng_A - int_lo) * (pG(int_hi) - pG(int_lo))
   zClip(l_sng_A,pComp.clipLo,pComp.clipHi)
   p_ret = l_sng_A
   pComp.tile.x1 += pComp.tile.xStep
#EndMacro
Sub RGBAA_PaletteStream(pPalette() As UInteger, ByRef pR_ As ComponentAnimProps,ByRef pG_ As ComponentAnimProps,ByRef pB_ As ComponentAnimProps,ByRef pA1 As ComponentAnimProps,ByRef pA2 As ComponentAnimProps,sR_() As Single,sG_() As Single,sB_() As Single,sA1() As Single,sA2() As Single,ByVal DoIncrement As Integer = -1)

   zRGBAA_PaletteStream_FourCommonComponents(pR_,pG_,pB_,pA1,sR_,sG_,sB_,sA1,1,2,3,5)
   zStretchPan pA2,sA2(),sng1,AnimAlpha * -DoIncrement,5
   
   Dim As Single   sng3,sng4,sng5

   For I As UInteger Ptr = @pPalette(0) To @pPalette(mPalUB_)
      zPaletteStream_Component(sng1,pR_,sR_)
      zPaletteStream_Component(sng2,pG_,sG_)
      zPaletteStream_Component(sng3,pB_,sB_)
      If MaxAlpha Then
      *I = RGBA(sng1,sng2,sng3,255)
      Else
      zPaletteStream_Component(sng4,pA1,sA1)
      zPaletteStream_Component(sng5,pA2,sA2)
      *I = RGBA(sng1,sng2,sng3,sng4+sng5)
      EndIf
   Next

End Sub
Sub GradientPass(ByVal TickAnimation As Integer = TRUE)
   RGBAA_PaletteStream mPalette(),PS_R,PS_G,PS_B,PS_A1,PS_A2, _
      gradient_R(),gradient_G(),gradient_B(),gradient_A1(),gradient_A2(),TickAnimation
End Sub
Sub NewColors(ByVal pSpeed As Single=0.28)
   Gradient mGInfo,2,50,25+Rnd*25,0
   DefComponent PS_R,mGInfo,gradient_R(),305,-50,0.003*pSpeed,0.0041*pSpeed,,,255

   Gradient mGInfo,2,50,25+Rnd*25,0
   DefComponent PS_G,mGInfo,gradient_G(),305,-50,0.004*pSpeed,0.0051*pSpeed,,,255

   Gradient mGInfo,2,50,25+Rnd*25,0
   DefComponent PS_B,mGInfo,gradient_B(),305,-50,0.005*pSpeed,0.0061*pSpeed,,,255
End Sub
Sub NewAlphas(ByVal pSpeed As Single=0.28)
Dim As Single Peak = 250, Valley = -300
Peak += 255

   Gradient mGInfo,3,30,25+Rnd*55,31
   DefComponent PS_A1,mGInfo,gradient_A1(),Peak,Valley,0.0071*pSpeed,0.0079*pSpeed,2.05*(0.66+Rnd),,127

   Gradient mGInfo,3,30,25+Rnd*55,31
   DefComponent PS_A2,mGInfo,gradient_A2(),Peak,Valley,0.0057*pSpeed,0.0053*pSpeed,2.05*(0.67+Rnd),,128
End Sub
Sub NewGradients(ByVal pSpeed As Single=0.28)
   NewColors pSpeed
   NewAlphas pSpeed
   GradientPass FALSE
End Sub
''                                          ''
''         Custom 5 Gradients End           ''
''                                          ''
'' ======================================== ''

'' =========================================== ''
''                                             ''
''             Mandelbrot Begin                ''
''                                             ''
''                                             ''
Dim Shared As Const Double      log2 = Log (2.0)

Type ComplexNumber
   As Double                    Re, Im
End Type
Type ComplexPixel
   As ComplexNumber             Z
   As Double                    dist
End Type

Type MandelRect
   As ComplexNumber             Center
End Type

#Macro Modulus(pValue,pModulus)
   If pValue >= pModulus Then
      pValue -= pmodulus * Int(pValue / pModulus)
   End If
#EndMacro
#Macro zSQ_C()
   Tmp = P.Z.Re
   P.Z.Re = P.Z.Re * P.Z.Re - P.Z.Im * P.Z.Im + C.Re
   P.Z.Im = 2 * Tmp * P.Z.Im + C.Im
   P.dist = P.Z.Re * P.Z.Re + P.Z.Im * P.Z.Im
#EndMacro
#Macro Distance(ret,input1,input2)
   ret = Sqr( input1 * input1 + input2 * input2 )
#EndMacro
Private Sub MRectCenter(ByRef pMR As MandelRect,ByVal cRe As Double,ByVal cIm As Double)
   pMR.Center.Re = cRe
   pMR.Center.Im = cIm
End Sub
Sub Alpha256(ByRef dest As UInteger,ByVal foreground As UInteger,ByVal alph As UInteger)
Dim As UInteger temp_ = (dest And &HFF00FF00) Shr 8
Dim As UInteger rb_ = dest And &H00FF00FF

   ''This sub interprets alpha from 0 to 256

   ''http://stereopsis.com/doubleblend.html
   ''http://www.virtualdub.org/blog/pivot/entry.php?id=117

   dest = (foreground And &HFF00FF00) Shr 8
   dest -= temp_   '' AG channels
   
   dest *= alph
   dest += &H800080   '' "0.5" -> Int(sng + 0.5)
   dest += temp_ Shl 8
   dest And= &HFF00FF00
   
   temp_ = foreground And &H00FF00FF
   temp_ -= rb_   '' RB channels
   temp_ *= alph
   temp_ += &H800080   '' "0.5" -> Int(sng + 0.5)
   temp_ Shr= 8
   temp_ += rb_

   dest Or= temp_ And &H00FF00FF

End Sub
Private Sub CalcVal(ByRef C As complexnumber,ByVal IterCount As UInteger)
Dim As Double Tmp
Dim As UInteger N,Temp_
Dim As ComplexPixel P

   For N = 1 To IterCount
      zSQ_C()
      If P.dist > 401 Then Exit For
   Next
   
   If N > IterCount Then
      N -= 1
      m_sng = 0
      hMap_HiRes(x,y).PalEntry = 0
   Else     
      '' http://linas.org/art-gallery/escape/escape.html
      N += 2
      zSQ_C()
      zSQ_C()
      distance(Tmp,P.Z.Re,P.Z.Im)
      m_sng = SuperSample * ( N - (log (log (Tmp)))/ log2)
      Modulus(m_sng,mPalUB_)
      CIntF(Temp_,m_sng)
      hMap_HiRes(x,y).PalEntry = Temp_
   EndIf

End Sub
Private Sub CalcMan(pHiRes As ImageInfo, ByVal IterCount As UShort,ByVal xc As Double = -0.6,ByVal yc As Double = 0.0,ByVal rad1 As Double = 3.5,ByVal rad2 As Double = 3.5)
Dim As ComplexNumber C,LerpAC,LerpAB
Dim As MandelRect    MRect
Dim As Double        Steppa, left_, top_, dest_diagonal = Sqr(pHiRes.wid^2+pHiRes.hgt^2)
Dim As UInteger Ptr  ptr_FG,sPTR,sPtr_L,ptr_FG_L
Dim As Integer       X2,Y2

   mPalUB_ = UBound(mPalette)
   MRectCenter MRect, xc,yc

   Distance(Steppa,rad1,rad2)
   
   left_ = -Sqr(Steppa) * (pHiRes.wid / dest_diagonal)
   top_ = -Sqr(Steppa) * (pHiRes.hgt / dest_diagonal)
   
   Steppa = Sqr((2*left_) ^ 2 + (2*top_) ^ 2) / dest_diagonal

   left_ += MRect.Center.Re
   top_ += MRect.Center.Im
   
   ''background image as big as window
   Put (0,0),img_B.img,PSET

   C.Im = top_
   For Y = 0 To pHiRes.hgtM
      C.Re = left_
      Y2 = Y\bmpfileScale
     
      '' img_F is the "alpha layer" as big as window
      ptr_FG_L = img_F.pixels + Y2 * img_F.pitch
      sPtr_L = ScreenPtr + Y2 * mpitch
     
      For X = 0 To pHiRes.widM
         
         X2 = X\bmpfileScale
         sPTR = sPtr_L
         sPTR += X2
         ptr_FG = ptr_FG_L
         ptr_FG += X2
         CalcVal C, IterCount
         
         *ptr_FG = mPalette(hMap_HiRes(x,y).PalEntry)
         hMap_WndRes(X2,Y2) = hMap_HiRes(x,y)
         
         'HiRes buffer has 4x as many pixels as Window.
         
         'As such, I produce this checkpoint so the Foreground,
         'buffer encounters only one write per pixel.
         If Y / bmpfileScale = Int(Y / bmpfileScale) Then
         If X / bmpfileScale = Int(X / bmpfileScale) Then
         Alpha256 *sPTR,*ptr_FG, *ptr_FG Shr 24
         End if
         End If

         ptr_FG += 1

         C.Re += Steppa
      Next
     
      StatusUpdate(Y)

      ScreenLock
      ScreenUnLock
      C.Im += Steppa
      If multikey(FB.SC_ESCAPE) Then Exit For
   Next

End Sub
''                                   ''
''          Mandelbrot End           ''
''                                   ''
'' ================================= ''

'' ============================== ''
''                                ''
''         Save BMP Begin         ''
''                                ''
''                                ''
Type RGBQUAD_
Blue  As Byte
Green As Byte
Red   As Byte
Alpha As Byte
End Type
Type BITMAPINFOHEADER
   biSize          As UInteger
   biWidth         As UInteger
   biHeight        As UInteger
   biPlanes        As UShort
   biBitCount      As UShort
   biCompression   As UInteger
   biSizeImage     As UInteger
   biXPelsPerMeter As UInteger
   biYPelsPerMeter As UInteger
   biClrUsed       As UInteger
   biClrImportant  As UInteger
End Type
Type BitmapFileHeader
   As String * 2 bfType = "BM"
   bfSize As UInteger
   bfReserved1 As UShort
   bfReserved2 As UShort
   bfOffBits As UInteger
End Type
Const BI_RGB      As Integer =0
#Macro zSaveLoad(pVar)
   If DoSave Then
      Put #1,,pVar
   Else
      Get #1,,pVar
   EndIf
#EndMacro
#Macro BMP_FileHeader()
   With tBMF
   zSaveLoad(.bfType)
   zSaveLoad(.bfSize)
   zSaveLoad(.bfReserved1)
   zSaveLoad(.bfReserved2)
   zSaveLoad(.bfOffBits)
   End With
#EndMacro
#Macro BMP_FileBIH()
   With tBIH
   zSaveLoad(.biSize)
   zSaveLoad(.biWidth)
   zSaveLoad(.biHeight)
   zSaveLoad(.biPlanes)
   zSaveLoad(.biBitCount)
   zSaveLoad(.biCompression)
   zSaveLoad(.biSizeImage)
   zSaveLoad(.biXPelsPerMeter)
   zSaveLoad(.biYPelsPerMeter)
   zSaveLoad(.biClrUsed)
   zSaveLoad(.biClrImportant)
   End With
#EndMacro
Sub RetA(ByRef ret As UByte,ByVal pCol As UInteger)
   ret = pCol Shr 8
End Sub
Sub RetR(ByRef ret As UByte,ByVal pCol As UInteger)
   ret = pCol
End Sub
Sub RetG(ByRef ret As UByte,ByVal pCol As UInteger)
   ret = pCol Shr 24
End Sub
Sub RetB(ByRef ret As UByte,ByVal pCol As UInteger)
   ret = pCol Shr 16
End Sub
Function FileBMP32(fileName As String,pHiRes As ImageInfo,ByVal DoSave As Integer = FALSE) As String
Dim tBMF As BitmapFileHeader
Dim tBIH As BITMAPINFOHEADER
Dim strResult As String = "Fail!"
Dim tRGBQ() As RGBQUAD_

   'http://en.wikipedia.org/wiki/BMP_file_format

   tBIH.biHeight = pHiRes.hgt
   tBIH.biWidth = pHiRes.wid
   tBIH.biPlanes = 1
   tBIH.biBitCount = 32
   tBIH.biSize = Len(tBIH)
   tBIH.biSizeImage = 0 'No Compression
   tBIH.biCompression = BI_RGB
   
   tBMF.bfOffBits = 54
   tBMF.bfSize = 54 + 4 * pHiRes.wid * pHiRes.hgt
   
Dim As UByte bytes(pHiRes.wid*4 - 1)

   Open filename For Output As #1
      Write #1,,""
   Close #1
   
   Open fileName For Binary As #1

   BMP_FileHeader()
   BMP_FileBIH()
   
   ''Future development

'   If Not DoSave Then   
'      img_Load.Create(tBIH.biWidth,tBIH.biHeight)
'   End If

   Dim As UInteger X2
   Dim As UInteger Ptr src, imgPtrL

   For y_ As Integer = 0 To pHiRes.hgtM
      If DoSave Then
      imgPtrL = pHiRes.pixels + (pHiRes.hgtM-y_) * pHiRes.pitch
      Else
'      imgPtrL = img_Load.pitch + (img_Load.hgt-y_)*img_Load.pitch
      EndIf
      src = imgPtrL
      If DoSave Then
         For x_ As Integer = 0 To pHiRes.widM
            x2 = x_ * 4
            RetR bytes(x2), *src
            RetA bytes(x2+1), *src
            RetB bytes(x2+2), *src
            RetG bytes(x2+3), *src
            src += 1
         Next
         Put #1, , bytes()
      Else
         Get #1, , bytes()
         For x_ As Integer = 0 To pHiRes.widM
            x2 = x_*4
            *src = RGBA(bytes(x2),bytes(x2+3),bytes(x2+2),bytes(x2+1))
            src += 1
         Next
      End If
      StatusUpdate(y_)
   Next
   
'   If Not DoSave Then
'      img_Load.Destroy
'   EndIf
   
   Close #1
   
   strResult = "Success!"
   Return strResult

End Function
Sub SaveBMP
Dim As String StrResult

   StrResult = FileBMP32("mand .bmp",img_HiRes,TRUE)

End Sub
''                                   ''
''          Save BMP End             ''
''                                   ''
'' ================================= ''

'' =================================== ''
''                                     ''
''           Render Begin              ''
''                                     ''
''                                     ''
Dim Shared As Integer  Paused=TRUE, Dithered = TRUE, Text_Y, TimeTrig
Dim Shared As Uinteger mOffsetX,mOffsetY ''dithering for faster animation
Sub zRenderPass_DitherMask(pDest As ImageInfo,pcMap() As hMap)
Dim As UInteger pitchV2X2 = pDest.pitchV2 * 2
Dim As UInteger Ptr destL = pDest.pixels, dest
   destL += mOffsetY * pDest.pitchV2
   destL += mOffsetX
   For y_ as Integer = mOffsetY To pDest.hgt - 1 Step 2
      dest = destL
      For x_ As hMap Ptr = @pcMap(mOffsetX,y_) To @pcMap(pDest.wid-1,y_) Step pDest.hgt * 2
         *dest = mPalette(x_->PalEntry)
         dest += 2
      Next
      destL += pitchV2X2
   Next
End Sub
Sub zRenderPass_DitherPatt_OddEven(pDest As ImageInfo,pcMap() As hMap)
   zRenderPass_DitherMask pDest,pcMap()
   mOffsetY = 1
   mOffsetX = 1 - mOffsetX
   zRenderPass_DitherMask pDest,pcMap()
   mOffsetY = 0
End Sub
Sub RenderPass(ByVal SavBMP As Integer = FALSE)
   If SavBMP Then
      zRenderPass_DitherPatt_OddEven img_HiRes,hMap_HiRes()
      zRenderPass_DitherPatt_OddEven img_HiRes,hMap_HiRes()
   Else
      zRenderPass_DitherPatt_OddEven img_F,hMap_WndRes()
   EndIf
End Sub
''                                   ''
''            Render End             ''
''                                   ''
'' ================================= ''

'' =================================== ''
''                                     ''
''          Interface Begin            ''
''                                     ''
''                                     ''
#Define NoText NULL
Dim Shared As UInteger TextColor = RGBA(24,35,0,235)
Dim Shared As UInteger TextColorQ = RGBA(0,0,0,165)
Dim Shared As Integer  DoShowHelp = TRUE
Dim Shared As Double   tdelta,time_now,qsave_timer
Dim Shared As String   qSilk,qPlayDirection,qPause
Dim Shared As String   qAlpha,qColor,qMaxAlpha
Sub qText
   If Dithered Then qSilk = "Dithered": Else qSilk = "Silky"
   If MaxAlpha Then qMaxAlpha = "Full Alpha": Else qMaxAlpha = "Transparent"
   If Paused Then
      qPlayDirection = "Paused"
      qAlpha = "Paused"
      qColor = "Paused"
   Else
      If DoRewind Then qPlayDirection = "Reverse": Else qPlayDirection = "Forward"
      If AnimAlpha Then qAlpha = "Moving": Else qAlpha = "Static"
      If AnimColor Then qColor = "Moving": Else qColor = "Static"
   EndIf
End Sub
Sub PrintLine(ByRef pStr As String)
   Draw String (4, Text_Y), pStr, TextColor
   Text_Y += 10
End Sub
Sub PrintLineQ(ByRef pStr As string, ByRef pStrQ As String)
   Draw String (4, Text_Y), pStr, TextColor
   Draw String (5 + Len(pStr)*8, Text_Y), pStrQ, TextColorQ
   Text_Y += 10
End Sub
Sub PrintInfo

   If DoShowHelp Then

   Text_Y = 4
   PrintLine " Keys:"
   PrintLine ""
   PrintLineQ "(F1) ", "Help Screen"
   PrintLine ""
   PrintLineQ "(G) ", "New Gradient"
   PrintLineQ "(0) ", "New Alpha"
   PrintLineQ "(1) ", "New Color"
   PrintLineQ "(F) ", qMaxAlpha
   PrintLine ""
'   PrintLineQ "(Q) ", qSilk
'   PrintLine ""
   PrintLineQ "(spacebar) ", "Pause"
   PrintLineQ "(< or >) ", "Frame Step"
   PrintLine ""
   PrintLineQ "(R) Play Direction ", qPlayDirection
   PrintLine ""
   PrintLineQ "(C) Color ", qColor
   PrintLineQ "(A) Alpha ", qAlpha
   PrintLine ""
   
   End If
   
   If TimeTrig Then
      time_now = Timer
      tdelta = time_now - qsave_timer
      If tDelta >= 1.5 Then
         TimeTrig = FALSE
      EndIf
      PrintLineQ "(S) ", "(Image Saved)"
   Else
      If DoShowHelp Then PrintLineQ "(S) ", "Save 32-bit Bmp"
   End If

End Sub
Sub RenderPass_Moderator
   Dim As Integer Silky = Not Dithered
   If Silky Then RenderPass
   RenderPass
End Sub
Sub Refresh(ByVal DrawText As Integer = TRUE, ByVal NewGradient As Integer = FALSE, ByVal AdvanceFrame As Integer = FALSE)
   ScreenLock
      Put (0,0),img_B.img,PSet
      If Paused Then
         If NewGradient Then
            RenderPass: RenderPass
         ElseIf AdvanceFrame Then
            RenderPass_Moderator
         EndIf
      Else
         RenderPass_Moderator
      EndIf
      Put (0,0),img_F.img,Alpha
      If DrawText Then PrintInfo
   ScreenUnLock
End Sub
Sub UserFrameAdvance(ByVal pForward As Integer = TRUE)
   Paused = TRUE
   DoRewind = Not pForward
   GradientPass
   qText: Refresh,,TRUE
End Sub
''                                   ''
''           Interface End           ''
''                                   ''
'' ================================= ''


img_F.Create
img_B.Create
CheckerBackground img_B

Randomize

NewGradients

CalcMan img_HiRes,Iterations

qText
If Paused Then Refresh

Dim As Integer L

Do While 1

   If Paused Then
   Else
      GradientPass
        Refresh
   EndIf

   If (ScreenEvent(@e)) Then
      if e.type = EVENT_KEY_PRESS Then
         Select Case e.scancode
            
            Case SC_1
         NewColors
         If Paused Or (Not AnimColor) Then
         GradientPass FALSE
         Refresh ,TRUE
         End If
         
            Case SC_0
         If Not MaxAlpha Then NewAlphas
         MaxAlpha = FALSE
         If Paused Or Not AnimAlpha Then
         GradientPass FALSE
         End If
         qText
         Refresh ,TRUE
         
            Case SC_F1
         DoShowHelp = Not DoShowHelp
         If Paused Then Refresh
         
            Case 51, 75 ''<, L arrow
         UserFrameAdvance FALSE
            Case 52, 77 ''>, R arrow
         UserFrameAdvance TRUE
         
            Case SC_SPACE, SC_P
         Paused = Not Paused
         qText: Refresh
         
            Case SC_F
         MaxAlpha = Not MaxAlpha
         If MaxAlpha Then AnimAlpha = FALSE
         qText': If Paused Then RenderPass: Refresh
         GradientPass FALSE
         Refresh ,TRUE

            Case SC_S
         RenderPass TRUE
         SaveBMP
         qsave_timer = Timer: TimeTrig = TRUE
         Refresh
         
            Case SC_R
         DoRewind = Not DoRewind
         If Paused Then
            Paused = FALSE
         EndIf
         qText
         
'            Case SC_Q
'         Dithered = Not Dithered
'         qText: If Paused Then Refresh: If Not Dithered Then RenderPass

            Case SC_ESCAPE
         Exit Do

            Case SC_G
         NewGradients
         Refresh ,TRUE

            Case SC_A
         AnimAlpha = Not AnimAlpha
         If Paused Then Paused = FALSE: AnimAlpha = TRUE: AnimColor = FALSE
         If MaxAlpha Then AnimAlpha = False
         MaxAlpha = False
         qText

            Case SC_C
         AnimColor = Not AnimColor
         If Paused Then Paused = FALSE: AnimColor = TRUE: AnimAlpha = FALSE
         qText

         End Select
      Elseif e.type = EVENT_KEY_Repeat Then
         Select Case e.scancode
            Case 51, 75 ''<, L arrow
         UserFrameAdvance FALSE
            Case 52, 77 ''>, R arrow
         UserFrameAdvance TRUE
         End Select
      End If
   End If

   Sleep 30
   
Loop

img_B.Destroy
img_F.Destroy
img_HiRes.Destroy
Last edited by dafhi on Jan 23, 2012 8:23, edited 12 times in total.
dodicat
Posts: 6234
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: mandelbrot

Postby dodicat » Oct 21, 2011 23:05

Pretty cool stuff dafhi, and mesmerising.

I see that you macro CIntD(i,f), actually rounds up over .5 and down under .5, unlike INT.
dafhi
Posts: 1329
Joined: Jun 04, 2005 9:51

Postby dafhi » Oct 22, 2011 2:55

Thanks doder
dafhi
Posts: 1329
Joined: Jun 04, 2005 9:51

Re: mandelbrot

Postby dafhi » Jan 16, 2012 5:04

Nice update
kiyotewolf
Posts: 1009
Joined: Oct 11, 2008 7:42
Location: ABQ, NM
Contact:

Re: mandelbrot

Postby kiyotewolf » Jan 17, 2012 6:30

bfType As String * 2 = "BM"


This line would not compile with my version of FreeBasic.

Did this get patched in later versions?



~Kiyote!

Had to put in a tiny re-write, but.. eh. Is fine.

My version : Version 0.20.0 Beta:
TJF
Posts: 3503
Joined: Dec 06, 2009 22:27
Location: N47°, E15°
Contact:

Re: mandelbrot

Postby TJF » Jan 17, 2012 7:00

kiyotewolf wrote:
bfType As String * 2 = "BM"


This line would not compile with my version of FreeBasic.

Did this get patched in later versions?

Nothing to patch in FB here !?!

Do you mean
    DIM AS STRING *2 var_name = "BM"
kiyotewolf
Posts: 1009
Joined: Oct 11, 2008 7:42
Location: ABQ, NM
Contact:

Re: mandelbrot

Postby kiyotewolf » Jan 17, 2012 7:47

Type BitmapFileHeader
bfType As String * 2 = "BM"
bfSize As UInteger
bfReserved1 As UShort
bfReserved2 As UShort
bfOffBits As UInteger
End Type


I got this error.

C:\Program Files\FreeBASIC\fbc -s gui "fract_2.bas"
fract_2.bas(502) error 21: Type mismatch in 'bfType As String * 2 = "BM"'

Build error(s)


When I removed the definition of that part of the TYPE and moved it into the regular code as an assignment, it worked.
TJF
Posts: 3503
Joined: Dec 06, 2009 22:27
Location: N47°, E15°
Contact:

Re: mandelbrot

Postby TJF » Jan 17, 2012 8:18

kiyotewolf wrote:I got this error.

You got? And what will you get if you do it now :)

Being serious: I get no error when I compile this (fbc 0.23 on Ubuntu11.10):

Code: Select all

TYPE BitmapFileHeader
  bfType AS STRING * 2 = "BM"
  bfSize AS UINTEGER
  bfReserved1 AS USHORT
  bfReserved2 AS USHORT
  bfOffBits AS UINTEGER
END TYPE

Check if you use 'bfType' as a SHAREd variable or TYPE or MACRO somewhere in the rest of the code.

Try also
    #PRINT TYPEOF(bfType)
before your UDT definition. (Outputs when fbc is compiling.)
kiyotewolf
Posts: 1009
Joined: Oct 11, 2008 7:42
Location: ABQ, NM
Contact:

Re: mandelbrot

Postby kiyotewolf » Jan 17, 2012 8:30

My version : FreeBasic 0.20.0 Beta:


I am being serious, and, I'm compiling directly from the source listed in the first post.



~Kiyote!
TJF
Posts: 3503
Joined: Dec 06, 2009 22:27
Location: N47°, E15°
Contact:

Re: mandelbrot

Postby TJF » Jan 17, 2012 9:15

kiyotewolf wrote:I am being serious, ...

And I was not at the beginning of my last post ;)

What do you get from
    #PRINT TYPEOF(bfType)
fxm
Posts: 9529
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: mandelbrot

Postby fxm » Jan 17, 2012 9:19

kiyotewolf wrote:I got this error.

C:\Program Files\FreeBASIC\fbc -s gui "fract_2.bas"
fract_2.bas(502) error 21: Type mismatch in 'bfType As String * 2 = "BM"'

Build error(s)


When I removed the definition of that part of the TYPE and moved it into the regular code as an assignment, it worked.

Before the fbc version 0.21.0, we could not use an initializer just after a fix-len string declaration syntax (not only in a Type). We had to do this in two separated lines, or to modify the terms order.

Extract of the 'changelog.txt', Version 0.21.0 Beta, [fixed]:
- 'dim a as string * expr = ""' wasn't working because of expression/varinit ambiguity (dkls)
(ambiguity is due to the expression part 'expr = ""')

Remark:
'dim as string * expr a = ""' worked.
Last edited by fxm on Jan 17, 2012 9:55, edited 3 times in total.
kiyotewolf
Posts: 1009
Joined: Oct 11, 2008 7:42
Location: ABQ, NM
Contact:

Re: mandelbrot

Postby kiyotewolf » Jan 17, 2012 9:27

Should I do the whole "ADD REMOVE PROGRAMS" method to purge the old version, before I install a newer version?



~Kiyote!

And, I can't do the #print command, cause it won't even compile.
fxm
Posts: 9529
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: mandelbrot

Postby fxm » Jan 17, 2012 9:42

fxm wrote:
kiyotewolf wrote:I got this error.

C:\Program Files\FreeBASIC\fbc -s gui "fract_2.bas"
fract_2.bas(502) error 21: Type mismatch in 'bfType As String * 2 = "BM"'

Build error(s)


When I removed the definition of that part of the TYPE and moved it into the regular code as an assignment, it worked.

Before the fbc version 0.21.0, we could not use an initializer in a fix-len string declaration (not only in a Type). We had to do this in two separated lines.

Extract of the 'changelog.txt', Version 0.21.0 Beta, [fixed]:
- 'dim a as string * expr = ""' wasn't working because of expression/varinit ambiguity (dkls)

More precisely, it depends on the syntax:
dim a as string * expr = ""
was forbidden,
but:
dim as string * expr a = ""
WORKED!!!

For your example:

Code: Select all

TYPE BitmapFileHeader
  AS STRING * 2 bfType = "BM"
  bfSize AS UINTEGER
  bfReserved1 AS USHORT
  bfReserved2 AS USHORT
  bfOffBits AS UINTEGER
END TYPE
works without compiler (0.20.0) error

[Edit]
- Previous post updated consequently.
Last edited by fxm on Jan 17, 2012 11:48, edited 1 time in total.
kiyotewolf
Posts: 1009
Joined: Oct 11, 2008 7:42
Location: ABQ, NM
Contact:

Re: mandelbrot

Postby kiyotewolf » Jan 17, 2012 9:48

Oh, nice.

Syntax can be annoying.

I've thought about doing stuff in depreciated, but I don't like the idea of getting all syntax -like in one mode, then trying to switch around.



~Kiyote!
dafhi
Posts: 1329
Joined: Jun 04, 2005 9:51

Re: mandelbrot

Postby dafhi » Jan 17, 2012 10:26

Thanks for your input! It has been updated :)

Return to “Tips and Tricks”

Who is online

Users browsing this forum: MSN [Bot] and 1 guest