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