' VB6 code (c)2014 Mikle http://www.fbsl.net/phpbb2 ' FBSL port (c)2014 Mike Lobanovsky http://www.fbsl.net/phpbb2 ' BaCon port (c)2015 Peter van Eerten http://www.basic-converter.org INCLUDE canvas.bac DECLARE Col[1024][768], CC[128][8], NZ[512][512], WB[1024][768], WX[1024][768], WY[1024][768] TYPE static int DECLARE SX, SY, FC TYPE static double CONST M_TWOPI = 2.0*PI DEF FN GetRValue(x) = x & 0xFF DEF FN GetGValue(x) = (x>>8) & 0xFF DEF FN GetBValue(x) = (x>>16) & 0xFF DEF FN RAND = (double)RND/MAXRANDOM FUNCTION Lerp(int c1, int c2, double k) TYPE int LOCAL d = 1.0 - k TYPE double RETURN (int)((c1 & 0xFF)* k + (c2 & 0xFF) * d) \ | ((int)((c1 & 0xFF00)* k + (c2 & 0xFF00) * d) & 0xFF00) \ | ((int)((c1 & 0xFF0000)* k + (c2 & 0xFF0000) * d) & 0xFF0000) END FUNCTION FUNCTION BN(double x, double y, double sunx, double suny) TYPE double LOCAL ix, iy, dx, dy TYPE int LOCAL isx, isy TYPE double ix = FLOOR(x): iy = FLOOR(y) dx = (ix + 1) & 511: dy = (iy + 1) & 511 sunx = x - ix: suny = y - iy isx = 1.0 - sunx: isy = 1.0 - suny ix = ix & 511: iy = iy & 511 RETURN (double)(NZ[ix][iy] * isx * isy + NZ[dx][iy] * sunx * isy + NZ[ix][dy] * isx * suny + NZ[dx][dy] * sunx * suny) END FUNCTION FUNCTION BC(double x, double y, double sunx, double suny) TYPE int LOCAL ix, iy, c0, c1, c2, c3 TYPE int LOCAL ixy, isxy, isyx, xy TYPE double ix = FLOOR(x): iy = FLOOR(y) sunx = x - ix: suny = y - iy ixy = (1.0 - sunx) * (1.0 - suny) isxy = sunx * (1.0 - suny): isyx = suny * (1.0 - sunx) xy = sunx * suny c0 = CC[ix & 127][iy % 9] c1 = CC[(ix + 1) & 127][iy % 9] c2 = CC[ix & 127][(iy + 1) % 9] c3 = CC[(ix + 1) & 127][(iy + 1) % 9] RETURN (c0 & 0xFF)* ixy + (c1 & 0xFF)* isxy + (c2 & 0xFF)* isyx + (c3 & 0xFF)* xy \ + ((int)((c0 & 0xFF00)* ixy + (c1 & 0xFF00)* isxy + (c2 & 0xFF00)* isyx + (c3 & 0xFF00)* xy) & 0xFF00) \ + ((int)((c0 & 0xFF0000)* ixy + (c1 & 0xFF0000)* isxy + (c2 & 0xFF0000)* isyx + (c3 & 0xFF0000)* xy) & 0xFF0000) END FUNCTION SUB Initialize LOCAL x, y, d = 64, d2 = 128 TYPE int SEED NOW WHILE TRUE FOR y = 0 TO 511 STEP d2 FOR x = 0 TO 511 STEP d2 NZ[(x + d) & 511][y] = (NZ[x][y] + NZ[(x + d2) & 511][y])* 0.5 + d * (RAND - 0.5) NZ[x][(y + d) & 511] = (NZ[x][y] + NZ[x][(y + d2) & 511]) * 0.5 + d * (RAND - 0.5) NZ[(x + d) & 511][(y + d) & 511] = (NZ[x][y] + NZ[(x + d2) & 511][(y + d2) & 511] \ + NZ[x][(y + d2) & 511] + NZ[(x + d2) & 511][y]) * 0.25 + d * (RAND - 0.5) NEXT NEXT IF d = 1 THEN BREAK d = d>>1: d2 = d + d WEND END SUB SUB Colorize LOCAL x, y, xx, yy, c, r, g, b TYPE int 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 c = Col[xx + x * 8][yy + y * 48] INCR r, (c & 0xFF) INCR g, (c & 0xFF00) INCR b, ((c & 0xFF0000) >> 8) NEXT NEXT CC[x][y] = r / 384 + ((g / 384) & 0xFF00) + (((b / 384) & 0xFF00) << 8) NEXT CC[x][8] = CC[x][7] NEXT ENDSUB SUB Sky LOCAL x, y, c1, c2 TYPE int LOCAL k, s, sx1, sy1, dy TYPE double SX = 100 + RAND * 824: SY = 192 + RAND * 157 FOR y = 0 TO 383 sy1 = 100000.0 / (390.0 - y) FOR x = 0 TO 1023 sx1 = (x - 511.5) * sy1 * 0.0005 k = BN(sx1, sy1, SX, SY) - BN(sx1 * 0.14 + sy1 * 0.21, sy1 * 0.14 - sx1 * 0.21, SX, SY) IF k < -8.0 THEN k = 0.0 ELSE k = (k + 8.0) * 0.02 :'cloud density ENDIF IF k > 1.0 THEN k = 1.0 dy = y / 384.0 FC = 0x908000 + (SY + 500.0) * 0.2 :' haze tint c1 = Lerp(FC + 25, 0x906050, dy) c2 = Lerp(0x807080, 0xD0D0D0, dy) s = 30.0 / SQR((x - SX) * (x - SX) + (y - SY) * (y - SY)) :' sun size IF s > 1.0 THEN s = 1.0 c1 = Lerp(0xFFFFFF, c1, s) Col[x][y] = Lerp(c2, c1, k) NEXT NEXT ENDSUB SUB Water LOCAL x, y TYPE int LOCAL x1, yy1, k, kx, sx1, sy1, sx2, sy2 TYPE double FOR y = 767 TO 384 STEP -1 k = (y - 383) * 0.5: kx = (900 - y) / 580.0 FOR x = 1023 TO 0 STEP -1 sy1 = 64000.0 / (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, SX, SY) - BN(sx2, sy2, SX, SY) 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]) yy1 = 768.0 - y + WY[x][y] IF yy1 < 0.0 THEN yy1 = 0.0 ELIF yy1 > 383.0 THEN yy1 = 383.0 ENDIF Col[x][y] = Lerp(BC(x1 / 8, yy1 / 48, SX, SY), 0x251510, kx): 'water tint NEXT NEXT ENDSUB SUB Air LOCAL x, y, c TYPE int LOCAL k1, k2, s TYPE double LOCAL col TYPE int FOR y = 0 TO 767 k1 = POW((1.0 - ABS(383.5 - y) / 384.0), 5.0) FOR x = 0 TO 1023 IF y = SY THEN k2 = 0.25 ELSE k2 = ATN((x - SX) / (y - SY)) / M_TWOPI + 0.25 ENDIF IF y - SY < 0 THEN INCR k2, 0.5 k2 = BN(k2 * 512.0, 0.0, SX, SY) * 0.03 k2 = 0.2 - k2 * k2: IF k2 < 0.0 THEN k2 = 0.0 s = 30.0 / SQR((x - SX) * (x - SX) + (y - SY) * (y - SY)) IF s > 1.0 THEN s = 1.0 c = Lerp(0xFFFFFF, FC, k2 * (1.0 - s)) col = Lerp(c, Col[x][y], k1) INK(GetRValue(col), GetGValue(col), GetBValue(col), 255) PIXEL(x, y) NEXT NEXT ENDSUB WINDOW("Seascape", 1024, 768) CALL Initialize() CALL Sky() CALL Colorize() CALL Water() CALL Air() WAITKEY