' Sets the graphics method GDI ' 描画方法を GDI に設定 SetEnviron("fbgfx=GDI") ' パラメータは、お使いの環境やお好みに合わせて、変更できます Const scr_width As Integer = 640 '320 640 800 ...,1280 Const scr_height As Integer = 480 '240 480 600 ...800 const fullscreen as Integer = 0 ' 0/1 '1:fullscreen Const max_itera As Integer = 128 '64 - 256 ' 以下は変更しないで下さい Const w_last As Integer = scr_width - 1 Const h_last As Integer = scr_height - 1 Const q4 As Integer = 4 Const steps As Double = 20 Dim As Integer anim,itera,cfade,frames,fps,help Dim As Double two,r,rstep,i,istep,ioffset,roffset Dim As Double r_max,r_min,i_max,i_min,rdiff,idiff,zoom Dim As Double roffsetsoll,ioffsetsoll,zoomsoll Dim As Double roffsetdiff,ioffsetdiff,zoomdiff Dim As Double roffsetstep,ioffsetstep,zoomstep Dim As Integer x2y2,col1,col2,flag,t1,t2 Dim As Integer xm,ym,l,a,x,y,work_page,visible_page = 1 Dim As Byte Ptr video_page Dim As String k Dim As Single rc,gc,bc,w rdiff=3.4*scr_width/scr_height idiff=3.4 two =2.0 zoom =1 anim =1 cfade=1 help =1 if fullscreen then screenres scr_width,scr_height,,,1 setmouse 0,0,0 else screenres scr_width,scr_height end if For l=1 To 255 rc=Sin(w)*0.5+0.5 gc=Cos(w*1.25)*0.5+0.5 bc=Sin(w*1.5)*0.5+0.5 Palette l,rc*255,gc*255,bc*255 w=w+0.1 Next t1=timer 'open "waypoints.txt" for append as #2 While a<>27 '[esq]=end rstep=rdiff*zoom/scr_width istep=idiff*zoom/scr_height r_min=roffset-(rdiff*zoom*0.5) i_min=ioffset-(idiff*zoom*0.5) video_page=screenptr screenlock asm mov edi,[video_page] i=i_min For y=0 To h_last r=r_min For x=0 To w_last asm Xor ecx,ecx fld qword Ptr [r] fld qword Ptr [i] fldz fldz fld qword Ptr [two] fldz fldz 'y,x,2,y2,x2,i,r asm_iterastep: fld st(2) '2,y,x,2,y2,x2,i,r fmul st(0),st(1) '2*y fmul st(0),st(2) '2*y*x fadd st(0),st(6) '2*y*x+i fxch st(1) 'y,2*y*x*i,x,2,y2,x2,i,r fstp st(0) 'y,x,2,y2,x2,i,r fld st(4) 'x2 ,y,x,2,y2,x2,i,r fsub st(0),st(4) 'x2y2 ,y,x,2,y2,x2,i,r fadd st(0),st(7) 'x2y2r ,y,x,2,y2,x2,i,r fxch st(2) 'x,y,x2y2r,2,x2,i,r fstp st(0) 'y,x,2,y2,x2,i,r fld st(1) 'x,y,x,2,y2,x2,i,r fmul st(0) 'xx,y,x,2,y2,x2,i,r fxch st(5) 'x2,y,x,2,y2,xx,i,r fstp st(0) 'y,x,2,y2,x2,i,r fld st(0) 'y ,y,x,2,y2,x2,i,r fmul st(0) 'y*y,y,x,2,y2,x2,i,r fxch st(4) ' fstp st(0) 'y,x,2,y2,x2,i,r inc ecx cmp ecx,max_itera jge asm_nomandel fld st(3) 'y2,y,x,2,y2,x2,i,r fadd st(0),st(5) fistp dword Ptr [x2y2]'y,x,2,y2,x2,i,r mov eax,dword Ptr [x2y2] cmp eax,q4 'then goto ismandel jg asm_ismandel jmp asm_iterastep asm_nomandel: Xor cx,cx asm_ismandel: 'Shl cl,1 mov Byte Ptr [edi],cl asm_xstep: inc edi fstp st(0) 'x,2,y2,x2,i,r fstp st(0) '2,y2,x2,i,r fstp st(0) 'y2,x2,i,r fstp st(0) 'x2,i,r fstp st(0) 'i,r fstp st(0) 'r fadd qword Ptr [rstep] fstp qword Ptr [r] 'fpu stack empty end asm Next asm fld qword Ptr [istep] fadd qword Ptr [i] fstp qword Ptr [i] 'fpu stack empty end asm Next if anim=0 then line (scr_width\2-5,scr_height\2 )-step(10,0),255 line (scr_width\2 ,scr_height\2-5)-step(0,10),255 end if if help then locate 1,1:color 0,0 draw string (0, 0),"[h] on/off helpscreen" draw string (0,10),"[c] on/off colorfade" draw string (0,20),"[a] on/off animation" draw string (0,30),"[+][-] zoom in/out" draw string (0,40),"[left][right] move left/right" draw string (0,50),"[up] [down] move up /down" if fps then draw string (0,70),"frames per second:" & fps end if end if screenunlock frames+=1 if frames>=50 then t2=timer if (t2-t1)>=3.0 then fps=frames/(t2-t1) if fullscreen=0 then windowtitle "FPS=" & fps end if t1=t2:frames=0 end if end if k=Inkey:l=Len(k) If l Then a=Asc(Mid(k,l,1)) Select Case a ' Case 13 ' [return] save curent waypoint ' print #2,"data ";roffset;",";ioffset;",";zoom Case 97 ' [a] togle animation on/off anim=anim Xor 1 Case 99 ' [c] togle colorfade on/off cfade=cfade Xor 1 Case 104 ' [h] togle help instruction on/off help=help Xor 1 ' cursor move [left][rigth][up][down] Case 72 ioffset-=istep*2 Case 80 ioffset+=istep*2 Case 75 roffset-=rstep*2 Case 77 roffset+=rstep*2 ' [+][-] zomm in/out Case 45 'zoom out zoom+=rstep*8 Case 43 'zoom in zoom-=rstep*8 End Select End If If anim Then If flag=0 Then Read roffsetsoll,ioffsetsoll,zoomsoll If roffsetsoll=-1.0 And ioffsetsoll=-1.0 And zoomsoll=-1.0 Then Restore Read roffsetsoll,ioffsetsoll,zoomsoll End If roffsetdiff=(roffset-roffsetsoll)/100.0 ioffsetdiff=(ioffset-ioffsetsoll)/100.0 zoomdiff=(zoom-zoomsoll)/100.0 flag=100 End If roffset-=roffsetdiff ioffset-=ioffsetdiff zoom-=zoomdiff flag-=1 End If If cfade Then Palette Get 1,col1 For l=1 To 254 Palette Get l+1,col2 Palette l,col2 Next Palette 255,col1 End If Wend ' close waypoint file 'close #2 End Data -1.429768163191177, 0, 0.05827402421943742 Data -1.429916265921348, 0, 2.547174155824884e-06 Data -1.447242800619238,-0.02075477953116167, 0.01853105315282292 Data -1.448491719244281,-0.01683185615982145, 0.000218250277751366 Data -1.448494962416383,-0.01685102895821514, 1.271832197158205e-05 Data -1.448540366825824,-0.01684899402669969, 1.271832197158205e-05 Data -1.448540211341738,-0.01684882329907699, 1.049950669433006e-07 Data -1.448540221908983,-0.01684881859373112, 6.686868933306398e-09 Data -1.448540221650768,-0.01684881825349504, 6.075644447976854e-10 Data -1.448540221693981,-0.01684881825349504, 8.876504632190959e-11 Data -1.448540222056144,-0.01684881831740589, 8.876504632190959e-11 Data -1.448540222056144,-0.01684881831740589, 0.0048015208111237 Data -1.447315834249308,-0.006093411700488804, 0.0048015208111237 Data -1.447575410718678,-0.006302817927879772, 0.0004362629737311815 Data -1.447546060932151,-0.006275194599384553, 0.0001150972020634162 Data -1.447549946836704,-0.006278851921316968, 1.142913103880331e-05 Data -1.447549953773961,-0.006278904154782063, 2.720492973799422e-08 Data -1.447549953773961,-0.006278904154782063, 0.0959551631790438 Data -1.847203208414673,-0.006278904154782063, 0.0959551631790438 Data -1.860985543961812, 5.730536102542537e-05, 0.02472605136870849 Data -1.861382365188764, 0.0001280447521777783, 7.575700083603683e-07 Data -1.861382300909908, 0.000128060841636056, 6.787177454139503e-10 Data -1.861382300909908, 0.000128060841636056, 1.80301591945143 Data 0.1309502900839218, 1.298299522846665, 1.80301591945143 Data -0.1984145909714904, 1.100352449330687, 0.001352409399890011 Data -0.1987733287401083, 1.100407573501614, 8.613151707517529e-05 Data -0.1987927587686087, 1.100406817836918, 1.88916174031882e-06 Data -0.1987926341447898, 1.100406706717228, 7.716645119686126e-08 Data -0.1987926374785418, 1.100406704868181, 2.620466114794424e-10 Data -0.1987926374785418, 1.100406704868181, 0.002943719650420304 Data -0.2065493387573994, 1.106765139313087, 0.002943719650420304 Data -0.206697724315536, 1.106402031123765, 0.0003491424897332628 Data -0.2067125121193846, 1.106368035391356, 1.193999868780553e-05 Data -0.2067148243436442, 1.106365903599446, 9.856968272467161e-08 Data -0.2067148338391115, 1.106365912536355, 1.396392244558323e-08 Data -0.2067148338391115, 1.106365912816002, 6.570202991474562e-10 Data -0.2067148338855405, 1.106365912816002, 4.997933986013956e-11 Data -0.2067148338502975, 1.106365912809265, 4.565903560075121e-12 Data -0.2067148338219658, 1.106365912799768, 4.565903560075121e-12 Data -0.2067148338219658, 1.106365912799768, 1.329455317510298e-07 Data -0.2067143705067878, 1.106365997884909, 1.329455317510298e-07 Data -0.2067143793444081, 1.10636599573528, 3.1423647016843e-11 Data -0.2067143793495975, 1.106365995736637, 3.391748679138347e-12 Data -0.2067143793494169, 1.106365995736712, 2.360785268886536e-13 Data -0.2067143793494169, 1.106365995736712, 8.62035957278071e-08 Data -0.2067139910022188, 1.106366050907014, 8.12035957278071e-08 Data -0.0, 1.106366050907014, 10.0 Data -0.2067139910022188, 0.0, 20.0 Data 0.0, 0.0, 1.0 Data -1.0,-1.0,-1.0
' +--------------------------------------------------+ ' ' | palettizer ' +--------------------------------------------------+ ' ' Sets the graphics method GDI ' 描画方法を GDI に設定 SetEnviron("fbgfx=GDI") Type GradientRibbon As UShort Sections As UShort widBase,widVari As Single UBPix As Single Shatter End Type Type zTileAnimProperties 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 zTileAnimProperties 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 Namespace FTI '' ==================== float to int ======================== '' "Because Int() is slow" ''https://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 CIntD(i,f) asm fld qword ptr [f] asm fistp dword ptr [i] #endmacro #macro CeilF(i,f) SCW(i) fld dword ptr [f] fchs fistp dword ptr [i] neg dword ptr [i] RCW() #endmacro #macro CeilD(i,d) SCW(i) fld qword ptr [d] fchs fistp dword ptr [i] neg dword ptr [i] RCW() #endmacro #macro FloorF(i,d) SCW(i) fld dword ptr [d] fistp dword ptr [i] RCW() #endmacro #macro FloorD(i,d) SCW(i) fld qword ptr [d] fistp dword ptr [i] RCW() #EndMacro End Namespace '' ================================================= '' end of Float-To-Int '' ================================================= #Macro zPieceVal(Valu) Valu = alphaLo + Rnd * (alphaHi-alphaLo) #EndMacro #Macro zComponent_Start_PrvEnd(I_,mX1_) zPieceVal(mSng) m_yStart(I_) = mSng '* 256 + &H80 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 #Macro zGradientModulus(pOutput,pInput,pInfo) If pOutput >= pInfo.UBPix Then FloorF(int_lo,in_by_ub) pOutput = pInput - pInfo.UBPix * int_lo ElseIf pOutput < 0 Then FloorF(int_lo,in_by_ub) pOutput = pInput - pInfo.UBPix * int_lo End If #EndMacro Function GradientVal(ByVal pInput As Single, ByRef pInfo As GradientRibbon,pGradient() As Single) As Single Dim As Integer int_lo Dim As Single in_by_ub_S = pInput: in_by_uB_S /= pInfo.UBPix Dim As Single in_by_ub = in_by_uB_S zGradientModulus(pInput,pInput,pInfo) FloorF(int_lo,pInput) Dim As Integer int_hi = int_lo + 1 Function = pGradient(int_lo) + (pInput - int_lo) * (pGradient(int_hi) - pGradient(int_lo)) End Function Type RGBQUAD2 ''RGBQUAD defined in windows.bi Blue As UByte Green As UByte Red As UByte Alpha As UByte End Type Type HSVTYPE Val8 As UByte Sat8 As UByte Hue16 As Short ''0 to 1529 is a complete cycle. 1530 is a repeat of 0 [red] End Type Dim Shared As Integer mHueBase, mValue, mSatu, mValue_, mHue #Macro zHSV2RGB(pCompA,pCompB,pMeas_) If mHue < pMeas_ Then pCompA = mValue pCompB = mValue - mSatu * (pMeas_ - mHue) / 255& Else pCompA = mValue - mSatu * (mHue - pMeas_) / 255& pCompB = mValue End If #EndMacro Sub HSVTYPE_To_RGBQUAD(ByRef pDest As RGBQUAD2, ByRef pSrc As HSVTYPE) Dim As Single A_ = pSrc.Hue16 / 1530& CIntF(mHue,A_) mHue = pSrc.Hue16 - 1530& * mHue'Int(pSrc.Hue16 / 1530&) mValue = pSrc.Val8 mSatu = mValue * CInt(pSrc.Sat8) / 255& If mHue < 511& Then pDest.Blue = mValue - mSatu zHSV2RGB(pDest.Red, pDest.Green, 255&) ElseIf mHue < 1021& Then pDest.Red = mValue - mSatu zHSV2RGB(pDest.Green, pDest.Blue, 765&) Else pDest.Green = mValue - mSatu zHSV2RGB(pDest.Blue, pDest.Red, 1275&) End If End Sub Private sub zPaletteStream_EndPoints(ByRef pAnimHSV As ComponentAnimProps,pGradient() As Single,ByVal pSng As Single,ByVal DoIncrement As Integer,ByVal DefaultCase As Integer) pAnimHSV.tile.x1 = (pAnimHSV.tile.rotRadi * Sin(pAnimHSV.tile.A0)) * pAnimHSV.infoRibbon.UBPix pAnimHSV.tile.x2 = (pAnimHSV.tile.tile + pAnimHSV.tile.rotRadi * Cos(pAnimHSV.tile.A1)) * pAnimHSV.infoRibbon.UBPix If DoIncrement Then pAnimHSV.tile.A0 += pAnimHSV.tile.iA0 pAnimHSV.tile.A1 += pAnimHSV.tile.iA1 End If pAnimHSV.tile.xStep = (pAnimHSV.tile.x2 - pAnimHSV.tile.x1) * pSng If pAnimHSV.clipLo = pAnimHSV.clipHi Then pAnimHSV.clipHi = pAnimHSV.alphaHi pAnimHSV.clipLo = pAnimHSV.alphaLo EndIf End Sub #Macro zPalStream_CompX4(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_ zPaletteStream_EndPoints pS1,sS1(),sng1,DoIncrement,Def1 zPaletteStream_EndPoints pS2,sS2(),sng1,DoIncrement,Def2 zPaletteStream_EndPoints pS3,sS3(),sng1,DoIncrement,Def3 zPaletteStream_EndPoints pS4,sS4(),sng1,DoIncrement,Def4 #EndMacro #Macro zClip(retVal,clipLo,clipHi) If retVal > clipHi Then retVal = clipHi ElseIf RetVal < clipLo Then retVal = clipLo End if #EndMacro Sub zGradientVal(ByRef pInput As Single, ByRef pInfo As GradientRibbon,pGradient() As Single) Dim As Integer int_lo If pInput >= pInfo.UBPix Then Dim As Single in_by_ub_S1 = pInput: in_by_uB_S1 /= pInfo.UBPix Dim As Single in_by_ub1 = in_by_uB_S1 FloorF(int_lo,in_by_ub1) pInput -= pInfo.UBPix * int_lo ElseIf pInput < 0 Then Dim As Single in_by_ub_S2 = pInput: in_by_uB_S2 /= pInfo.UBPix Dim As Single in_by_ub2 = in_by_uB_S2 FloorF(int_lo,in_by_ub2) pInput -= pInfo.UBPix * int_lo End If FloorF(int_lo,pInput) Dim As Integer int_hi = int_lo + 1 pInput = pGradient(int_lo) + (pInput - int_lo) * (pGradient(int_hi) - pGradient(int_lo)) End Sub #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 PalStream_RGBAA(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) zPalStream_CompX4(pR_,pG_,pB_,pA1,sR_,sG_,sB_,sA1,1,2,3,5) zPaletteStream_EndPoints pA2,sA2(),sng1,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_) zPaletteStream_Component(sng4,pA1,sA1) zPaletteStream_Component(sng5,pA2,sA2) *I = RGBA(sng1,sng2,sng3,sng4+sng5) Next End Sub ' ================================ ' gradient value after calculation ' ================================ #Macro Modulus(pValue,pModulus) If pValue >= pModulus Then pValue -= pmodulus * Int(pValue / pModulus) End If #EndMacro Sub Alpha257(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 '' =========================================== '' '' Mandelbrot generator '' '' =========================================== #Include "fbgfx.bi" #If __FB_LANG__ = "fb" Using fb #EndIf Dim e As EVENT Dim Shared As Integer SCR_W = 784 Dim Shared As Integer SCR_H = 588 Dim Shared As Integer WidM: WidM = SCR_W - 1 Dim Shared As Integer HgtM: HgtM = SCR_H - 1 Dim Shared As Integer mpitch Dim Shared As Single sngMidx: sngMidx = WidM/2 Dim Shared As Single sngMidy: sngMidy = HgtM/2 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 Declare Sub Create(ByVal pWid As UShort=SCR_W,ByVal pHgt As UShort=SCR_H,ByVal pRed As UByte=255,ByVal pGrn As UByte=255,ByVal pBlu As UByte=255,ByVal pAph As UByte=255) Declare Sub Destroy End Type Dim Shared As Single SuperSample = 58 Dim Shared As Integer PaletteSize: PaletteSize = 120 * SuperSample'*Sqr(sngMidx^2+sngMidy^2) 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 GradientRibbon mGInfo Dim Shared As ComponentAnimProps PS_R,PS_G,PS_B,PS_A1,PS_A2 Private Sub NewGradients(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 Gradient mGInfo,3,30,25+Rnd*55,31 DefComponent PS_A1,mGInfo,gradient_A1(),385,-345,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(),385,-345,0.0057*pSpeed,0.0053*pSpeed,2.05*(0.67+Rnd),,128 End Sub Dim Shared As Integer X,Y Dim Shared As Single m_sng Dim Shared As ImageInfo img_B,img_F,img_Wnd Type hMap As Long PalEntry End Type Dim Shared As hMap hMap(WidM,HgtM) Dim Shared As Uinteger mOffsetX,mOffsetY ''every other pixel for faster animation 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, RGB(pRed,pGrn,pBlu)) wid = pWid hgt = pHgt ImageInfo img, ,,, pitch, pixels End Sub Sub ImageInfo.Destroy() ImageDestroy img End Sub Sub Checkerboard(ByRef pInfo As ImageInfo,ByVal CheckerSize As UInteger = 16,ByVal pCheckGray As Byte = 64,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),RGB(pCheckGray,pCheckGray,pCheckGray),BF Next Next End Sub 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 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 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(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(x,y).PalEntry = Temp_ EndIf End Sub 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 Private Sub CalcMan(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_ Dim As UInteger Ptr ptr_FG,sPTR PalStream_RGBAA mPalette(),PS_R,PS_G,PS_B,PS_A1,PS_A2, _ gradient_R(),gradient_G(),gradient_B(),gradient_A1(),gradient_A2() mPalUB_ = UBound(mPalette) MRectCenter MRect, xc,yc Distance(Steppa,rad1,rad2) left_ = -Sqr(Steppa) * (SCR_W / SCR_Diagonal) top_ = -Sqr(Steppa) * (SCR_H / SCR_Diagonal) Steppa = Sqr((2*left_) ^ 2 + (2*top_) ^ 2) / SCR_DIAGONAL left_ += MRect.Center.Re top_ += MRect.Center.Im Put (0,0),img_B.img,PSET C.Im = top_ For Y = 0 To HgtM C.Re = left_ ptr_FG = img_F.pixels + Y * mpitch sPTR = ScreenPtr + Y * mpitch For X = 0 To WidM CalcVal C, IterCount *ptr_FG = mPalette(hMap(x,y).PalEntry) Alpha257 *sPTR,*ptr_FG,*ptr_FG Shr 24 C.Re += Steppa ptr_FG += 1 sPTR += 1 Next ScreenLock ScreenUnLock C.Im += Steppa If multikey(FB.SC_ESCAPE) Then Exit For Next End Sub Sub zRender_Dither() Dim As UInteger Ptr ptrStart = img_F.pixels ptrStart += mOffsetX For y_ as Integer = mOffsetY To HgtM Step 2 Dim As UInteger Ptr dest = ptrStart + img_F.wid * y_ For x_ As hMap Ptr = @hMap(mOffsetX,y_) To @hMap(WidM,y_) Step SCR_H * 2 *dest = mPalette(x_->PalEntry) dest += 2 Next Next End Sub Sub Render() ScreenLock Put (0,0),img_B.img,PSet zRender_Dither mOffsetY = 1 mOffsetX = 1 - mOffsetX zRender_Dither Put (0,0),img_F.img,Alpha ScreenUnLock mOffsetY = 0 End Sub Dim As Integer Paused ScreenRes SCR_W,SCR_H,32,, fb.GFX_ALPHA_PRIMITIVES ScreenInfo x,,,,mpitch img_F.Create img_B.Create Checkerboard img_B,17,127 Randomize NewGradients CalcMan 250 Do If Paused Then Else PalStream_RGBAA mPalette(),PS_R,PS_G,PS_B,PS_A1,PS_A2, _ gradient_R(),gradient_G(),gradient_B(),gradient_A1(),gradient_A2() Render EndIf If (ScreenEvent(@e)) Then if e.type = EVENT_KEY_PRESS Then Select Case e.scancode Case 42 'Shift Case SC_Space Paused = Not Paused Case SC_S BSave "mand .bmp",0 Case SC_ESCAPE Exit Do Case Else NewGradients End Select End If End If Sleep 30 Loop img_B.Destroy img_F.Destroy