FreeBASIC マンデルブロー集合

' 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