The most amazing VB6 Code ever

[timfrombriz]

Yes, this little bit of code will blow your mind, try it

Option Explicit
Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
Private BUFFER_SCREEN() As Long
Private BUFFER_SCREEN_BITMAP_INFO As BITMAPINFO
Private Const EngineWidth As Long = 1024
Private Const EngineHeight As Long = 768
Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long

Dim NZ() As Single
Dim WB(1024, 384 To 768) As Single
Dim WX(1023, 384 To 767) As Single
Dim WY(1023, 384 To 767) As Single
Dim Col(1023, 767) As Long
Dim CC(128, 8) As Long
Dim FC As Long
Dim SX As Single, SY As Single

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 27 Then Unload Me
If KeyCode = 32 Then
    Gen
    Sky
    fCC
    Water
    Air
    SetDIBits frm.hdc, frm.Image, 0, EngineHeight, BUFFER_SCREEN(0), BUFFER_SCREEN_BITMAP_INFO, 0&
End If
End Sub

Private Sub Form_Load()
With BUFFER_SCREEN_BITMAP_INFO.bmiHeader
    .biSize = 40
    .biWidth = EngineWidth
    .biHeight = -EngineHeight
    .biPlanes = 1
    .biBitCount = 32
    .biCompression = 0&
    .biSizeImage = ((((.biWidth * .biBitCount) + &H1F) And Not &H1F&) \ &H8) * Abs(.biHeight)
End With
ReDim BUFFER_SCREEN(EngineWidth * EngineHeight)
  Move 0, 0, 1024 * Screen.TwipsPerPixelX, 768 * Screen.TwipsPerPixelY
  Show
  Form_KeyDown 32, 0
End Sub

Private Sub Air()
  Dim x As Long, y As Long, c As Long, k1 As Single, k2 As Single, s As Single, yReal As Long
  For y = 0 To 767
    k1 = (1 - Abs(383.5 - y) / 384) ^ 5
    For x = 0 To 1023
      If y = SY Then
        k2 = 0.25
      Else
        k2 = Atn((x - SX) / (y - SY)) / 6.283186 + 0.25
      End If
      If (y - SY) < 0 Then k2 = k2 + 0.5
      k2 = BN(k2 * 512, 0) * 0.03
      k2 = 0.2 - k2 * k2: If k2 < 0 Then k2 = 0
      s = 50 / Sqr((x - SX) * (x - SX) + (y - SY) * (y - SY))
      If s > 1 Then s = 1
      c = Lerp(&HFFFFFF, FC, k2 * (1 - s))
      BUFFER_SCREEN(yReal + x) = Lerp(c, Col(x, y), k1)
    Next x
    yReal = yReal + EngineWidth
  Next y
End Sub

Private Sub Water()
  Dim x As Long, y As Long
  Dim x1 As Long, y1 As Long
  Dim k As Single, c As Long, kx As Single
  Dim sx1 As Single, sy1 As Single
  Dim sx2 As Single, sy2 As Single
  For y = 768 To 384 Step -1
    k = (y - 383) * 0.5
    kx = (900 - y) / 580
    For x = 1024 To 0 Step -1
      sy1 = 64000 / (y - 380)
      sx1 = (x - 511.5) * sy1 * 0.002
      sy2 = sy1 * 0.34 - sx1 * 0.71
      sx2 = sx1 * 0.34 + sy1 * 0.71
      sy1 = sy2 * 0.34 - sx2 * 0.21
      sx1 = sx2 * 0.34 + sy2 * 0.21
      WB(x, y) = BN(sx1, sy1) - BN(sx2, sy2)
      If x < 1024 And y < 768 Then
        WX(x, y) = (WB(x + 1, y) - WB(x, y)) * k * kx
        WY(x, y) = (WB(x, y + 1) - WB(x, y)) * k
        x1 = x + WX(x, y)
        If x1 < 0 Then x1 = -x1 Else If x1 > 1023 Then x1 = 2047 - x1
        y1 = 768 - y + WY(x, y)
        If y1 < 0 Then y1 = 0 Else If y1 > 383 Then y1 = 383
        c = Lerp(BC(x1 / 8, y1 / 48), &H352520, kx)
        Col(x, y) = c
      End If
    Next x
  Next y
End Sub

Private Sub Sky()
  Dim x As Long, y As Long, c1 As Long, c2 As Long, k As Single, s As Single
  Dim sx1 As Single, sy1 As Single
  SX = 100 + Rnd * 824
  SY = 192 + Rnd * 157
  For y = 0 To 383
    sy1 = 100000 / (390 - y)
    For x = 0 To 1023
      sx1 = (x - 511.5) * sy1 * 0.0005
      k = BN(sx1, sy1) - BN(sx1 * 0.14 + sy1 * 0.21, sy1 * 0.14 - sx1 * 0.21)
      If k < -8 Then k = 0 Else k = (k + 8) * 0.02: If k > 1 Then k = 1
      FC = &H908000 + (SY + 500) * 0.2
      c1 = Lerp(FC + 25, &H906050, y / 384)
      c2 = Lerp(&H807080, &HD0D0D0, y / 384)
      s = 50 / Sqr((x - SX) * (x - SX) + (y - SY) * (y - SY))
      If s > 1 Then s = 1
      c1 = Lerp(&HFFFFFF, c1, s)
      Col(x, y) = Lerp(c2, c1, k)
    Next x
  Next y
End Sub

Private Sub fCC()
  Dim x As Long, y As Long
  Dim xx As Long, yy As Long
  Dim r As Long, g As Long, b As Long
  For x = 0 To 127
    For y = 0 To 7
      r = 0: g = 0: b = 0
      For yy = 0 To 47
        For xx = 0 To 7
          r = r + (Col(xx + x * 8, yy + y * 48) And 255)
          g = g + (Col(xx + x * 8, yy + y * 48) And &HFF00&)
          b = b + ((Col(xx + x * 8, yy + y * 48) And &HFF0000) \ 256)
        Next xx
      Next yy
      CC(x, y) = r / 384 + ((g / 384) And &HFF00&) + ((b / 384) And &HFF00) * 256
    Next y
    CC(x, 8) = CC(x, 7)
  Next x
End Sub

Private Function BC(ByVal x As Single, ByVal y As Single) As Long
  Dim ix As Long, iy As Long, SX As Single, SY As Single
  Dim c0 As Long, c1 As Long, c2 As Long, c3 As Long
  ix = Int(x)
  SX = x - ix
  iy = Int(y)
  SY = y - iy
  c0 = CC(ix And 127, iy Mod 9)
  c1 = CC((ix + 1) And 127, iy Mod 9)
  c2 = CC(ix And 127, (iy + 1) Mod 9)
  c3 = CC((ix + 1) And 127, (iy + 1) Mod 9)
  BC = (c0 And 255) * (1 - SX) * (1 - SY) + (c1 And 255) * SX * (1 - SY) + (c2 And 255) * (1 - SX) * SY + (c3 And 255) * SX * SY + _
      ((c0 And &HFF00&) * (1 - SX) * (1 - SY) + (c1 And &HFF00&) * SX * (1 - SY) + (c2 And &HFF00&) * (1 - SX) * SY + (c3 And &HFF00&) * SX * SY And &HFF00&) + _
      ((c0 And &HFF0000) * (1 - SX) * (1 - SY) + (c1 And &HFF0000) * SX * (1 - SY) + (c2 And &HFF0000) * (1 - SX) * SY + (c3 And &HFF0000) * SX * SY And &HFF0000)
End Function

Private Function BN(ByVal x As Single, ByVal y As Single) As Single
  Dim ix As Long, iy As Long, SX As Single, SY As Single
  ix = Int(x)
  SX = x - ix
  iy = Int(y)
  SY = y - iy
  BN = NZ(ix And 511, iy And 511) * (1 - SX) * (1 - SY) + NZ((ix + 1) And 511, iy And 511) * SX * (1 - SY) + NZ(ix And 511, (iy + 1) And 511) * (1 - SX) * SY + NZ((ix + 1) And 511, (iy + 1) And 511) * SX * SY
End Function

Private Sub Gen()
  Dim x As Long, y As Long, d As Long
  Randomize Timer
  ReDim NZ(511, 511)
  d = 64
  Do
    For y = 0 To 511 Step d + d
      For x = 0 To 511 Step d + d
        NZ((x + d) And 511, y) = (NZ(x, y) + NZ((x + d + d) And 511, y)) * 0.5 + d * (Rnd - 0.5)
        NZ(x, (y + d) And 511) = (NZ(x, y) + NZ(x, (y + d + d) And 511)) * 0.5 + d * (Rnd - 0.5)
        NZ((x + d) And 511, (y + d) And 511) = (NZ(x, y) + NZ((x + d + d) And 511, (y + d + d) And 511) + NZ(x, (y + d + d) And 511) + NZ((x + d + d) And 511, y)) * 0.25 + d * (Rnd - 0.5)
      Next x
    Next y
    If d = 1 Then Exit Do
    d = d \ 2
  Loop
End Sub

Private Function Lerp(ByVal c1 As Long, ByVal c2 As Long, ByVal k As Single) As Long
  Lerp = ((c1 And 255) * k + (c2 And 255) * (1 - k)) Or ((c1 And &HFF00&) * k + (c2 And &HFF00&) * (1 - k) And &HFF00&) Or ((c1 And &HFF0000) * k + (c2 And &HFF0000) * (1 - k) And &HFF0000)
End Function

[Mehmood Iqbal]

Only Coding, Its Really Interesting & Amazing !!!

[MarkT]

I'm impressed!

[seenu_1st]

Wow!!! Unbelievable.
it's not same all the time, the lightings varying...

[LaVolpe]

it's not same all the time, the lightings varying...

Use of the Rnd function in some of the equations.

Yep, neat code. Seen it on this forum before (graphics portion I believe). This code has been floating around the net for awhile now.

[jpbro]

It is quite spectacular - too bad there are no comments!

[gep13]

Since there isn't specifically a question related to this post, I am going to move it to the Chit Chat forum. If anyone disagrees with this decision, please feel free to get in touch.

Gary

[Harsh Gupta]

Since there isn't specifically a question related to this post, I am going to move it to the Chit Chat forum. If anyone disagrees with this decision, please feel free to get in touch.

Gary

Shouldn't it be in either VB6 Codebank or General Programming discussion? Chit-chat seems really inappropriate.

Although, none of my business since you are a moderator. Just giving my 2 cents.

[timfrombriz]

I threw this in VB6 code because thats what it is, and because that forum was most active because i felt it deserves a look by any legacy vb6 coders because of its artistic value.

code originally from pouet demoscene, sunrise is the production name, and i improved the renderer to make it 200x faster.

[MarkT]

I never would have seen it in the chit chat section.

[EntityX]

Chit Chat is really the only important forum that VBForums has.

I just have Visual Studio 2010. Would it be difficult to convert that to Visual Basic 2010?

[Aash]

bravo

[boops boops]

Great, at last someone is doing something useful with programming. I made a feeble attempt at something that in my 3D Text post (demo 2) -- see my signature. But this is a masterpiece in comparison.

I too would love to see it converted to VB.Net to see how it works and experiment with it. Unfortunately I never learned legacy VB so I can't do it myself.

BB

[Nightwalker83]

Cool! I wish all programs (games, etc) used code to create their graphics rather than having huge graphic/picture files.

[gep13]

Shouldn't it be in either VB6 Codebank or General Programming discussion? Chit-chat seems really inappropriate.

Although, none of my business since you are a moderator. Just giving my 2 cents.

Hello,

I did consider this, but given that there are no comments associated with the code in order for other people to truly benefit from it, I opted to put it here.

Gary

[gep13]

code originally from pouet demoscene, sunrise is the production name, and i improved the renderer to make it 200x faster.

Tim, if you have made changes to the code, and you feel that others can benefit from it, then I would encourage you to add comments to the code, and then re-post it in the VB6 CodeBank, that way others can really make use of it.

Gary

[MartinLiss]

Nice bit of code!

I'd add this to Form_Load


frm.Caption = "Press spacebar to change"


and add a few lines to the KeyDown sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 27 Then Unload Me
If KeyCode = 32 Then
    Screen.MousePointer = vbHourglass
    Gen
    Sky
    fCC
    Water
    Air
    SetDIBits frm.hdc, frm.Image, 0, EngineHeight, BUFFER_SCREEN(0), BUFFER_SCREEN_BITMAP_INFO, 0&
    frm.Refresh
    Screen.MousePointer = vbNormal
End If
End Sub

[LaVolpe]

I too would love to see it converted to VB.Net to see how it works and experiment with it. Unfortunately I never learned legacy VB so I can't do it myself.

Not a .Net user myself yet, but I'd think converting this to .Net would be relatively simple. One can create a 32 bit RGB bitmap object, lock its bitmap bits, then fill them in same as the code is doing for the BUFFER_SCREEN() array. When done, unlock the bitmap bits and assign the image to your form. No?

[EntityX]

I have absolutely no familiarity with VB6 but am attempting a conversion to Visual Basic 2010. You guys can help me out.

I'll take it in pieces. This first section of code I'd add Dim in front of all the code lines in between Private Type, End Type. Visual Studio suggests I replace Type with Structure. Would that work ok?

Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
Private BUFFER_SCREEN() As Long
Private BUFFER_SCREEN_BITMAP_INFO As BITMAPINFO ' Visual Studio suggests change BITMAPINFO to Bitmap
Private Const EngineWidth As Long = 1024
Private Const EngineHeight As Long = 768
Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long

Dim NZ() As Single
Dim WB(1024, 384 To 768) As Single ' wavy lines under 384's. VS2010 says, "array lower bounds can be only 0. 
Dim WX(1023, 384 To 767) As Single
Dim WY(1023, 384 To 767) As Single

Here's some more problem lines.

If KeyCode = 27 Then Unload(Me) ' wavy line under Unload. VS2010 says Unload is not declared. Provides option to generate method stub for Unload. 
 SetDIBits(frm.hdc, frm.Image, 0, EngineHeight, BUFFER_SCREEN(0), BUFFER_SCREEN_BITMAP_INFO, 0&) ' wavy lines under frm. Says frm is not declared. Suggests many different options here.

[dee-u]

SetDIBits frm.hdc, frm.Image, 0, EngineHeight, BUFFER_SCREEN(0), BUFFER_SCREEN_BITMAP_INFO, 0&

Copy pasted it and I had to change the frm to me and it worked.

[LaVolpe]

For those that want this converted to .Net, why not just post the code in the .Net forum and get some advice. Get it fixed/converted and repost it or link that .Net thread here. Just an idea.

[MartinLiss]

SetDIBits frm.hdc, frm.Image, 0, EngineHeight, BUFFER_SCREEN(0), BUFFER_SCREEN_BITMAP_INFO, 0&

Copy pasted it and I had to change the frm to me and it worked.

Or what I did was to (properly) name the form as 'frm'.

[InvisibleDuncan]

I'm genuinely impressed. I wouldn't have thought you could achieve this in VB.

[EntityX]

LaVolpe, I took your suggestion and posted the code in the VB.NET forum.

Convert VB6 Code to VB2010. Code from "The most amazing VB6 Code ever" thread

[Edgemeal]

Nice bit of code!

I'd add this to Form_Load


frm.Caption = "Press spacebar to change"

Agree, nice!

I believe the code was intended for a borderless form with no Caption, notice its sizing the form to the same size as the drawn graphics of 1024*768 and not taking into account the forms titlebar and border sizes.

Possible quick fix for sizeable form?...

Move 0, 0, (1024 * Screen.TwipsPerPixelX) + (Me.Width - Me.ScaleWidth), (768 * Screen.TwipsPerPixelY) + (Me.Height - Me.ScaleHeight)

[Rainmann]

I tweaked it some more. Changed all the hardcoded values to use the global constants instead (and added "HalfHeight" and "HalfWidth" contstants).

Now changing EngineWidth and EngineHeight will alter the size of the image. Make them match your screen resolution and you get... well, you get a full screen.

Option Explicit
Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
Private BUFFER_SCREEN() As Long
Private BUFFER_SCREEN_BITMAP_INFO As BITMAPINFO

Private Const EngineWidth As Long = 1680
Private Const EngineHeight As Long = 1050
Private Const HalfWidth As Long = EngineWidth / 2
Private Const HalfHeight As Long = EngineHeight / 2


Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long

Dim NZ() As Single
Dim WB(EngineWidth, HalfHeight To EngineHeight) As Single
Dim WX(EngineWidth - 1, HalfHeight To EngineHeight - 1) As Single
Dim WY(EngineWidth - 1, HalfHeight To EngineHeight - 1) As Single
Dim Col(EngineWidth - 1, 1060 - 1) As Long

Dim CC(128, 8) As Long
Dim FC As Long
Dim SX As Single, SY As Single

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 27 Then Unload Me
If KeyCode = 32 Then
    Screen.MousePointer = vbHourglass
    Gen
    Sky
    fCC
    Water
    Air
    SetDIBits frm.hdc, frm.Image, 0, EngineHeight, BUFFER_SCREEN(0), BUFFER_SCREEN_BITMAP_INFO, 0&
    frm.Refresh
    Screen.MousePointer = vbNormal
End If
End Sub



Private Sub Form_Load()
frm.Caption = "Press spacebar to change"
With BUFFER_SCREEN_BITMAP_INFO.bmiHeader
    .biSize = 40
    .biWidth = EngineWidth
    .biHeight = -EngineHeight
    .biPlanes = 1
    .biBitCount = 32
    .biCompression = 0&
    .biSizeImage = ((((.biWidth * .biBitCount) + &H1F) And Not &H1F&) \ &H8) * Abs(.biHeight)
End With
ReDim BUFFER_SCREEN(EngineWidth * EngineHeight)
  Move 0, 0, EngineWidth * Screen.TwipsPerPixelX, EngineHeight * Screen.TwipsPerPixelY
  Show
  Form_KeyDown 32, 0
End Sub

Private Sub Air()
  Dim x As Long, y As Long, c As Long, k1 As Single, k2 As Single, s As Single, yReal As Long
  For y = 0 To EngineHeight - 1
    k1 = (1 - Abs((HalfHeight - 0.5) - y) / HalfHeight) ^ 5
    For x = 0 To EngineWidth - 1
      If y = SY Then
        k2 = 0.25
      Else
        k2 = Atn((x - SX) / (y - SY)) / 6.283186 + 0.25
      End If
      If (y - SY) < 0 Then k2 = k2 + 0.5
      k2 = BN(k2 * HalfWidth, 0) * 0.03
      k2 = 0.2 - k2 * k2: If k2 < 0 Then k2 = 0
      s = 50 / Sqr((x - SX) * (x - SX) + (y - SY) * (y - SY))
      If s > 1 Then s = 1
      c = Lerp(&HFFFFFF, FC, k2 * (1 - s))
      BUFFER_SCREEN(yReal + x) = Lerp(c, Col(x, y), k1)
    Next x
    yReal = yReal + EngineWidth
  Next y
End Sub

Private Sub Water()
  Dim x As Long, y As Long
  Dim x1 As Long, y1 As Long
  Dim k As Single, c As Long, kx As Single
  Dim sx1 As Single, sy1 As Single
  Dim sx2 As Single, sy2 As Single
  For y = EngineHeight To HalfHeight Step -1
    k = (y - HalfHeight - 1) * 0.5
    kx = (900 - y) / 580
    For x = EngineWidth To 0 Step -1
      sy1 = 64000 / (y - (HalfHeight - 4))
      sx1 = (x - (HalfWidth - 5)) * sy1 * 0.002
      sy2 = sy1 * 0.34 - sx1 * 0.71
      sx2 = sx1 * 0.34 + sy1 * 0.71
      sy1 = sy2 * 0.34 - sx2 * 0.21
      sx1 = sx2 * 0.34 + sy2 * 0.21
      WB(x, y) = BN(sx1, sy1) - BN(sx2, sy2)
      If x < EngineWidth And y < EngineHeight Then
        WX(x, y) = (WB(x + 1, y) - WB(x, y)) * k * kx
        WY(x, y) = (WB(x, y + 1) - WB(x, y)) * k
        x1 = x + WX(x, y)
        If x1 < 0 Then x1 = -x1 Else If x1 > EngineWidth - 1 Then x1 = 2047 - x1
        y1 = EngineHeight - y + WY(x, y)
        If y1 < 0 Then y1 = 0 Else If y1 > HalfHeight - 1 Then y1 = HalfHeight - 1
        c = Lerp(BC(x1 / 8, y1 / 48), &H352520, kx)
        Col(x, y) = c
      End If
    Next x
  Next y
End Sub

Private Sub Sky()
  Dim x As Long, y As Long, c1 As Long, c2 As Long, k As Single, s As Single
  Dim sx1 As Single, sy1 As Single
  SX = 100 + Rnd * 824
  SY = 192 + Rnd * 157
  For y = 0 To HalfHeight - 1
    sy1 = 100000 / (HalfHeight + 6 - y)
    For x = 0 To EngineWidth - 1
      sx1 = (x - (HalfWidth - 5)) * sy1 * 0.0005
      k = BN(sx1, sy1) - BN(sx1 * 0.14 + sy1 * 0.21, sy1 * 0.14 - sx1 * 0.21)
      If k < -8 Then k = 0 Else k = (k + 8) * 0.02: If k > 1 Then k = 1
      FC = &H908000 + (SY + 500) * 0.2
      c1 = Lerp(FC + 25, &H906050, y / HalfHeight)
      c2 = Lerp(&H807080, &HD0D0D0, y / HalfHeight)
      s = 50 / Sqr((x - SX) * (x - SX) + (y - SY) * (y - SY))
      If s > 1 Then s = 1
      c1 = Lerp(&HFFFFFF, c1, s)
      Col(x, y) = Lerp(c2, c1, k)
    Next x
  Next y
End Sub

Private Sub fCC()
  Dim x As Long, y As Long
  Dim xx As Long, yy As Long
  Dim r As Long, g As Long, b As Long
  For x = 0 To 127
    For y = 0 To 7
      r = 0: g = 0: b = 0
      For yy = 0 To 47
        For xx = 0 To 7
          r = r + (Col(xx + x * 8, yy + y * 48) And 255)
          g = g + (Col(xx + x * 8, yy + y * 48) And &HFF00&)
          b = b + ((Col(xx + x * 8, yy + y * 48) And &HFF0000) \ 256)
        Next xx
      Next yy
      CC(x, y) = r / HalfHeight + ((g / HalfHeight) And &HFF00&) + ((b / HalfHeight) And &HFF00) * 256
    Next y
    CC(x, 8) = CC(x, 7)
  Next x
End Sub

Private Function BC(ByVal x As Single, ByVal y As Single) As Long
  Dim ix As Long, iy As Long, SX As Single, SY As Single
  Dim c0 As Long, c1 As Long, c2 As Long, c3 As Long
  ix = Int(x)
  SX = x - ix
  iy = Int(y)
  SY = y - iy
  c0 = CC(ix And 127, iy Mod 9)
  c1 = CC((ix + 1) And 127, iy Mod 9)
  c2 = CC(ix And 127, (iy + 1) Mod 9)
  c3 = CC((ix + 1) And 127, (iy + 1) Mod 9)
  BC = (c0 And 255) * (1 - SX) * (1 - SY) + (c1 And 255) * SX * (1 - SY) + (c2 And 255) * (1 - SX) * SY + (c3 And 255) * SX * SY + _
      ((c0 And &HFF00&) * (1 - SX) * (1 - SY) + (c1 And &HFF00&) * SX * (1 - SY) + (c2 And &HFF00&) * (1 - SX) * SY + (c3 And &HFF00&) * SX * SY And &HFF00&) + _
      ((c0 And &HFF0000) * (1 - SX) * (1 - SY) + (c1 And &HFF0000) * SX * (1 - SY) + (c2 And &HFF0000) * (1 - SX) * SY + (c3 And &HFF0000) * SX * SY And &HFF0000)
End Function

Private Function BN(ByVal x As Single, ByVal y As Single) As Single
  Dim ix As Long, iy As Long, SX As Single, SY As Single
  ix = Int(x)
  SX = x - ix
  iy = Int(y)
  SY = y - iy
  BN = NZ(ix And 511, iy And 511) * (1 - SX) * (1 - SY) + NZ((ix + 1) And 511, iy And 511) * SX * (1 - SY) + NZ(ix And 511, (iy + 1) And 511) * (1 - SX) * SY + NZ((ix + 1) And 511, (iy + 1) And 511) * SX * SY
End Function

Private Sub Gen()
  Dim x As Long, y As Long, d As Long
  Randomize Timer
  ReDim NZ(511, 511)
  d = 64
  Do
    For y = 0 To 511 Step d + d
      For x = 0 To 511 Step d + d
        NZ((x + d) And 511, y) = (NZ(x, y) + NZ((x + d + d) And 511, y)) * 0.5 + d * (Rnd - 0.5)
        NZ(x, (y + d) And 511) = (NZ(x, y) + NZ(x, (y + d + d) And 511)) * 0.5 + d * (Rnd - 0.5)
        NZ((x + d) And 511, (y + d) And 511) = (NZ(x, y) + NZ((x + d + d) And 511, (y + d + d) And 511) + NZ(x, (y + d + d) And 511) + NZ((x + d + d) And 511, y)) * 0.25 + d * (Rnd - 0.5)
      Next x
    Next y
    If d = 1 Then Exit Do
    d = d \ 2
  Loop
End Sub

Private Function Lerp(ByVal c1 As Long, ByVal c2 As Long, ByVal k As Single) As Long
  Lerp = ((c1 And 255) * k + (c2 And 255) * (1 - k)) Or ((c1 And &HFF00&) * k + (c2 And &HFF00&) * (1 - k) And &HFF00&) Or ((c1 And &HFF0000) * k + (c2 And &HFF0000) * (1 - k) And &HFF0000)
End Function

[tr333]

This would make a nice challenge to convert the code to HTML5+Canvas.

[TheBigB]

HELP
Can someone please ask a moderator to fix my account. I have zero posts? (update now its 1 but i have two on this thread?) and am (update: moderator pending approval new threads?) unable to send messages or post replies on the forum. I cant communicate other than edit my existing posts. Thanks!

Posts in chit-chat don't count towards your post count, and the first (5 or so?) posts need to be approved before becoming visible.
If you contribute a little to the forum (outside chit-chat) you'll be posting freely in no time

[wossname]

I was racking my brains to find some inspiration that would finally prompt me to smash myself repeatedly in the face with an electrified, acid-soaked chainsaw. Now I found it.

[Jenner]

Converted to VB.NET without all that wishy-washy GDI nonsense.

It's not optimal but it works.

[gep13]

Converted to VB.NET without all that wishy-washy GDI nonsense.

It's not optimal but it works.

Noice!

[eyestrain]

Huwow!


im amaze