'=========================================================================== ' Subject: 3D LANDSCAPE GENERATOR Date: 08-28-97 (13:59) ' Author: Danny Beardsley Code: QB, QBasic, PDS ' Origin: beards@dnai.com Packet: GRAPHICS.ABC '=========================================================================== '|______________________________________________________| '| A 3D LANDSCAPE GENERATOR USING FRACTALS IN SCREEN 13 | '| DANNY BEARDSLEY | '| EMAIL: dsb@cyberdude.com | '| HOMEPAGE http://www.dnai.com/~beards | '|------------------------------------------------------| DECLARE SUB LOADVAR () DECLARE SUB INITPAL () DECLARE SUB Splitbox (X1%, Y1%, X2%, Y2%) DECLARE SUB Newcolor (XA%, YA%, X%, Y%, XB%, YB%) DECLARE SUB DRW3DLAND () DECLARE SUB DRAWLAND () DECLARE SUB MAKELAND () DECLARE SUB setpal (Attr!, Red!, GREEN!, Blue!) SCREEN 13 CONST normaL = 0 CONST GREENVALLEY = 1 CONST ALPS = 2 DIM SHARED MAXX AS INTEGER, MAX.Y AS INTEGER, MAX.COLOR AS INTEGER, ROUGH!, K AS STRING, MUX AS INTEGER, MUY AS INTEGER, MBY, MBX, BBB AS INTEGER DIM SHARED ww AS INTEGER DIM SHARED Colr RANDOMIZE TIMER MAXX = 175 MAX.Y = 175 MAX.COLOR = 254 DIM SHARED Z(175 ^ 2) AS INTEGER DO RANDOMIZE TIMER '-------------SPECIFY THE VARIABLES HERE--------------- Colr = 3 'THREE DIF COLOR PALETTES ww = 20 'WATER LEVEL 0-250 ROUGH! = 1.8 'ROUGHNESS OF TERRAIN 0 = SMOOTH 5 = VERY ROUGH MAKELAND CLS INITPAL CLS DRW3DLAND SLEEP 4 LOOP REM $DYNAMIC SUB DRAWLAND DEFINT A-Z RANDOMIZE TIMER 'SLEEP 4 CLS PSET (0, 0), (RND * MAX.COLOR) + 1 'set the corners PSET (0, MAX.Y), (RND * MAX.COLOR) + 1 'set the corners PSET (MAXX, 0), (RND * MAX.COLOR) + 1 'set the corners PSET (MAXX, MAX.Y), (RND * MAX.COLOR) + 1 'set the corners 'use Set13Pixel to plant "seed" pixels here, if wanted Splitbox 0, 0, MAXX, MAX.Y END SUB DEFSNG A-Z SUB DRW3DLAND DEFINT A-Z LOCATE 25, 7 PRINT "(PRESS THE SPACEBAR TO EXIT)" N = 0 X1 = (6) / (374 / 300) + 174 Y2 = 255 X2 = (MAXX * 6) / (474 / 300) + 174 Y1 = 255 - 255 / (474 / 300) AX1 = 6 AY1 = MAX.Y * 2 AX2 = MAXX * 6 AY2 = MAX.Y * 2 + 254 FOR Y = 1 TO MAX.Y - 1 IF INKEY$ <> "" THEN END FOR X = 1 TO MAXX - 1 YO = Z(N) / ((175 - Y + 300) / 300) YO2 = Z(N + MAXX) / ((175 - Y + 300) / 300) N = N + 1 X1 = (X * 6) / ((175 - Y + 300) / 300) + (175 - Y) - 2 Y1 = Y * 2 + 254 - YO - 2 X2 = ((X + 1) * 6) / ((175 - Y + 300) / 300) + (175 - Y) + 2 Y2 = Y * 2 + 254 - YO2 + 2 LINE (X1 / 3.2, Y1 / 3.2)-(X2 / 3.2, Y2 / 3.2), Z(N), BF NEXT X N = N + 1 NEXT Y EXIT SUB FOR X = 1 TO MAXX - 1 YO = Z(N - MAXX) YO2 = 0 N = N + 1 X1 = (X * 6) - 2 Y1 = 174 * 2 + 254 - YO X2 = ((X + 1) * 6) + 2 Y2 = Y * 2 + 254 - YO2 LINE (X1 / 4, Y1 / 4)-(X2 / 4, Y2 / 4), 0, BF NEXT X 'DRWBOX 1, 253, AX1, AY1, AX2, AY2 END SUB REM $STATIC DEFSNG A-Z SUB INITPAL SELECT CASE Colr CASE normaL FOR I = 1 TO 63 setpal I, 0, (63 - I) / 2 + 20, 0 NEXT I FOR I = 64 TO 85 setpal I, (I - 64) * 1.5, 21 - (I - 64) / 4, 1 NEXT I FOR I = 1 TO 63 setpal I + 85, 32 - (I / 4), 15 - (I / 8), 3 NEXT I FOR I = 149 TO 170 setpal I, 16 + (I - 149) / 1.3, 7 + (I - 149), 4 + (I - 149) NEXT I FOR I = 1 TO 84 setpal I + 170, 32 + I / 3, 28 + I / 2.5, 25 + I / 2.6 NEXT I CASE 3 FOR I = 1 TO 63 setpal I, 0, (63 - I) / 2 + 20, 0 NEXT I FOR I = 64 TO 85 setpal I, (I - 64) / 1.5, 21 - (I - 64) / 1.5, 1 NEXT I FOR I = 1 TO 63 setpal I + 85, 16 + (I / 4), 7 + (I / 8), 3 NEXT I FOR I = 149 TO 170 setpal I, 32, 15 + (I - 149) / 1.6, 4 + (I - 149) NEXT I FOR I = 1 TO 84 setpal I + 170, 32 + I / 3, 28 + I / 2.5, 25 + I / 2.6 NEXT I CASE 4 FOR I = 1 TO 63 setpal I, 0, (63 - I) / 2 + 20, 0 NEXT I FOR I = 64 TO 85 setpal I, (I - 64) * 1.5, 21 - (I - 64) / 4, 1 NEXT I FOR I = 1 TO 150 setpal I + 85, 32 - (I / 10), 15 - (I / 20), 3 NEXT I FOR I = 235 TO 255 setpal I, 16 + (I - 235) / 1.3, 7 + (I - 235), 4 + (I - 235) NEXT I CASE GREENVALLEY FOR I = 1 TO 85 setpal I, 0, ((85 - I) / 1.349) / 2 + 20, 0 NEXT I FOR I = 85 TO 170 setpal I, (I - 85) / 2.666, 21 - (I - 85) / 16, 1 NEXT I FOR I = 1 TO 85 setpal I + 170, 32 - (I / 4), 15 - (I / 8), 3 NEXT I CASE ALPS FOR I = 1 TO 63 setpal I, 32 - (I / 4), 15 - (I / 8), 3 NEXT I FOR I = 64 TO 149 setpal I, 16 + (I - 64) / 5, 7 + (I - 64) / 4, 4 + (I - 64) / 4 NEXT I FOR I = 1 TO 105 setpal I + 149, 32 + I / 4, 28 + I / 4, 25 + I / 3 NEXT I END SELECT FOR I = 1 TO ww setpal I, 0, 0, 255 NEXT I END SUB SUB LOADVAR OPEN "C:\WINDOWS\LANSCAPE.INI" FOR INPUT AS 1 IF LOF(1) < 1 THEN Colr = INT(RND * 3) ww = INT(RND * 70) ROUGH! = (RND * 3) KILL "LANSCAPE.INI" CLOSE 1 EXIT SUB END IF INPUT #1, Colr, w$, ROUG$, CR, WR, ROR ww = VAL(w$) ROUGH! = VAL(ROUG$) / 10 CLOSE 1 END SUB REM $DYNAMIC DEFINT A-Z SUB MAKELAND DRAWLAND FOR X = 1 TO MAXX 'MOUSESTATUS MUX, MUY, BBB% 'IF MBX <> MUX OR MUY <> MBY THEN VIDEOMODESET VMODE: END 'MBX = MUX: MUY = MBY IF INKEY$ <> "" THEN END FOR Y = 1 TO MAX.Y R = POINT(X, Y) IF R < ww THEN R = ww Z(N) = R N = N + 1 NEXT Y NEXT X CLS END SUB SUB Newcolor (XA, YA, X, Y, XB, YB) 'puts a new color based on average IF POINT(X, Y) <> 0 THEN EXIT SUB avg = ABS(XA - XB) + ABS(YA - YB) COLOUR = (POINT(XA, YA) + POINT(XB, YB)) / 2 + (RND - .5) * avg * ROUGH! IF COLOUR > MAX.COLOR THEN COLOUR = MAX.COLOR IF COLOUR < 1 THEN COLOUR = 1 PSET (X, Y), COLOUR END SUB REM $STATIC DEFSNG A-Z SUB setpal (Attr, Red, GREEN, Blue) OUT &H3C7, Attr OUT &H3C8, Attr OUT &H3C9, Red OUT &H3C9, GREEN OUT &H3C9, Blue IF INKEY$ <> "" THEN END END SUB REM $DYNAMIC DEFINT A-Z ' SUB Splitbox (X1, Y1, X2, Y2) 'this is the main subroutine IF (X2 - X1 < 2) AND (Y2 - Y1 < 2) THEN EXIT SUB X = (X1 + X2) / 2 Y = (Y1 + Y2) / 2 Newcolor X1, Y1, X1, Y, X1, Y2 Newcolor X1, Y2, X, Y2, X2, Y2 Newcolor X2, Y2, X2, Y, X2, Y1 Newcolor X2, Y1, X, Y1, X1, Y1 'MOUSESTATUS MUX, MUY, BBB 'IF MBX <> MUX OR MUY <> MBY THEN VIDEOMODESET VMODE: END 'MBX = MUX: MUY = MBY IF POINT(X, Y) = 0 THEN IF INKEY$ <> "" THEN END COLOUR = (POINT(X1, Y1) + POINT(X2, Y1) + POINT(X1, Y2) + POINT(X2, Y2)) / 4 IF COLOUR > MAX.COLOR THEN COLOUR = MAX.COLOR IF COLOUR < 1 THEN COLOUR = 1 PSET (X, Y), COLOUR END IF Splitbox X1, Y1, X, Y Splitbox X, Y1, X2, Y Splitbox X, Y, X2, Y2 Splitbox X1, Y, X, Y2 END SUB