OK Paul,
I failed to find the VB6 original because the demo dates back to 2010 and the very few links that used to lead to the VB6 source code rather than its 4K executable are now broken with error code 404.
But I've found the FBSL BASIC equivalent (rather slow, I must admit).
It renders a non-persistent image directly to the on-screen window, and you shouldn't try to drag the window, or change focus, or change the window z-order before the calc completes, and drawing stops, and the overall time is displayed in the accompanying console. Otherwise the app will just freeze. The whole process takes approx. 30 secs to complete on my 3.6GHz PC.
(it's a single-threaded demo, after all)Whenever you see
Floor() in the code below, it stands for VB6/Sinclair/Spectrum
INT() in its truncate-towards-minus-infinity sense. Regretfully, the var names have been shortened/obfuscated, and comments, removed to yield an equivalent 4K-only tiny FBSL executable:
// VB6 code (c)2010 Mikle http://www.fbsl.net/phpbb2
// FBSL port (c)2014 Mike Lobanovsky http://www.fbsl.net/phpbb2
#AppType Console
#Include <Include/Windows.inc>
Dim %NZ[511, 511], WB[1024, 384 To 768], WX[1023, 384 To 767], WY[1023, 384 To 767]
Dim %Col[1023, 767], %CC[128, 8]
Dim FC, SX, SY, $PS * 64
SetWindowLong(ME, GWL_STYLE, &H6000000)
Resize(ME, 0, 0, 1024, 768)
Center(ME): Show(ME)
Begin Events
Select Case CBMSG
Case WM_NCHITTEST
Return HTCAPTION
Case WM_COMMAND
If CBWPARAM = 2 Then PostMessage(ME, WM_CLOSE, 0, 0)
Case WM_PAINT
InvalidateRect(ME, NULL, FALSE)
Render(BeginPaint(ME, PS)): EndPaint(ME, PS): Return 0
End Select
End Events
Sub Render(hDC)
Initialize()
Sky()
Colorize()
Water()
Air(hDC)
End Sub
Sub Initialize()
Dim x, y, d = 64, d2 = 128, gtc = GetTickCount()
Print "Running Initialize() ";
Randomize
Do
For y = 0 To 511 Step d2
For x = 0 To 511 Step d2
NZ[(x + d) BAnd 511, y] = (NZ[x, y] + NZ[(x + d2) BAnd 511, y]) * 0.5 + d * (Rnd() - 0.5)
NZ[x, (y + d) BAnd 511] = (NZ[x, y] + NZ[x, (y + d2) BAnd 511]) * 0.5 + d * (Rnd() - 0.5)
NZ[(x + d) BAnd 511, (y + d) BAnd 511] = (NZ[x, y] + NZ[(x + d2) BAnd 511, (y + d2) BAnd 511] + NZ[x, (y + d2) BAnd 511] + NZ[(x + d2) BAnd 511, y]) * 0.25 + d * (Rnd() - 0.5)
Next
Next
If d = 1 Then Exit Do
d = d \ 2: d2 = d + d
Loop
Print GetTickCount() - gtc, " msec"
End Sub
Sub Air(hDC)
Dim x, y, c, k1, k2, s, gtc = GetTickCount()
Print "Running Air() ";
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)) / M_TWOPI + 0.25
End If
If y - SY < 0 Then k2 = k2 + 0.5
k2 = BN(k2 * 512, 0) * 0.03
k2 = 0.2 - k2 ^ 2: If k2 < 0 Then k2 = 0
s = 30 / SqR((x - SX) ^ 2 + (y - SY) ^ 2)
If s > 1 Then s = 1
c = Lerp(&HFFFFFF, FC, k2 * (1 - s))
SetPixelV(hDC, x, y, Lerp(c, Col[x, y], k1))
Next
Next
Print GetTickCount() - gtc, " msec"
End Sub
Sub Water()
Dim x, y, x1, y1, k, kx, sx1, sy1, sx2, sy2, gtc = GetTickCount()
Print "Running Water() ";
For y = 767 DownTo 384
k = (y - 383) * 0.5: kx = (900 - y) / 580
For x = 1023 DownTo 0
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)
WX[x, y] = (WB[x + 1, y] - WB[x, y]) * k * kx
WY[x, y] = (WB[x, y + 1] - WB[x, y]) * k
x1 = Abs(x + WX[x, y])
y1 = 768 - y + WY[x, y]
If y1 < 0 Then
y1 = 0
ElseIf y1 > 383 Then
y1 = 383
End If
Col[x, y] = Lerp(BC(x1 / 8 / 2, y1 / 48 / 2), &H251510, kx) ' water tint
Next
Next
Print GetTickCount() - gtc, " msec"
End Sub
Sub Sky()
Dim x, y, c1, c2, k, s, sx1, sy1, dy, gtc = GetTickCount()
Print "Running Sky() ";
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 ' cloud density
End If
If k > 1 Then k = 1
dy = y / 384
FC = &H908000 + (SY + 500) * 0.2 ' haze tint
c1 = Lerp(FC + 25, &H906050, dy)
c2 = Lerp(&H807080, &HD0D0D0, dy)
s = 30 / SqR((x - SX) ^ 2 + (y - SY) ^ 2) ' sun size
If s > 1 Then s = 1
c1 = Lerp(&HFFFFFF, c1, s)
Col[x, y] = Lerp(c2, c1, k)
Next
Next
Print GetTickCount() - gtc, " msec"
End Sub
Sub Colorize()
Dim x, y, xx, yy, c, r, g, b, gtc = GetTickCount()
Print "Running Colorize() ";
For x = 0 To 127
For y = 0 To 7
Let(r, g, b) = 0
For yy = 0 To 47
For xx = 0 To 7
c = Col[xx + x * 8, yy + y * 48]
r = r + (c BAnd &HFF)
g = g + (c BAnd &HFF00)
b = b + ((c BAnd &HFF0000) >> 8)
Next
Next
CC[x, y] = r \ 384 + ((g \ 384) BAnd &HFF00) + (((b \ 384) BAnd &HFF00) << 8)
Next
CC[x, 8] = CC[x, 7]
Next
Print GetTickCount() - gtc, " msec"
End Sub
Function BC(x, y)
Dim ix = Floor(x), iy = Floor(y), SX = x - ix, SY = y - iy, c0, c1, c2, c3
Dim ixy = (1 - SX) * (1 - SY), isxy = SX * (1 - SY), isyx = SY * (1 - SX), xy = SX * SY
c0 = CC[ix BAnd 127, iy Mod 9]
c1 = CC[(ix + 1) BAnd 127, iy Mod 9]
c2 = CC[ix BAnd 127, (iy + 1) Mod 9]
c3 = CC[(ix + 1) BAnd 127, (iy + 1) Mod 9]
Return (c0 BAnd &HFF) * ixy + (c1 BAnd &HFF) * isxy + (c2 BAnd &HFF) * isyx + (c3 BAnd &HFF) * xy + _
((c0 BAnd &HFF00) * ixy + (c1 BAnd &HFF00) * isxy + (c2 BAnd &HFF00) * isyx + (c3 BAnd &HFF00) * xy BAnd &HFF00) + _
((c0 BAnd &HFF0000) * ixy + (c1 BAnd &HFF0000) * isxy + (c2 BAnd &HFF0000) * isyx + (c3 BAnd &HFF0000) * xy BAnd &HFF0000)
End Function
Function BN(x, y)
Dim ix = Floor(x), iy = Floor(y), SX = x - ix, SY = y - iy, isx = 1 - SX, isy = 1 - SY, dx = (ix + 1) BAnd 511, dy = (iy + 1) BAnd 511
ix = ix BAnd 511: iy = iy BAnd 511
Return NZ[ix, iy] * isx * isy + NZ[dx, iy] * SX * isy + NZ[ix, dy] * isx * SY + NZ[dx, dy] * SX * SY
End Function
Function Lerp(c1, c2, k)
Return((c1 BAnd &HFF) * k + (c2 BAnd &HFF) * (1 - k)) BOr (((c1 BAnd &HFF00) * k + (c2 BAnd &HFF00) * (1 - k)) BAnd &HFF00) BOr (((c1 BAnd &HFF0000) * k + (c2 BAnd &HFF0000) * (1 - k)) BAnd &HFF0000)
End Function
