It's designed so that you can go cross-eyed and (hopefully) see a planet in 3D...
DECLARE SUB InitPal () DECLARE SUB Pal (Index AS INTEGER, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER)
DECLARE SUB InitMap (Map() AS INTEGER, W AS INTEGER) DECLARE SUB DebugMap (Map() AS INTEGER, W AS INTEGER) DECLARE SUB DisplayMap (Map() AS INTEGER, W AS INTEGER, T AS INTEGER, D AS INTEGER, R AS INTEGER)
DECLARE FUNCTION GetPoint% (W AS INTEGER, Level AS INTEGER, YR AS INTEGER, P AS INTEGER, Quad AS INTEGER)
DIM I AS INTEGER, W AS INTEGER W = 63 DIM Map(0 TO W * 8 - 1, 0 TO W - 1) AS INTEGER
SCREEN 12
InitPal Pal 1, 0, 2, 58 Pal 2, 6, 12, 60 Pal 3, 13, 16, 60 Pal 4, 63, 60, 45 Pal 5, 33, 31, 26 Pal 6, 20, 51, 20 Pal 7, 21, 46, 10 Pal 8, 1, 26, 2 Pal 9, 4, 20, 0 Pal 10, 24, 24, 24 Pal 11, 44, 44, 45 Pal 12, 31, 29, 21 Pal 13, 9, 42, 5 Pal 14, 2, 40, 3 Pal 15, 2, 12, 50
RANDOMIZE TIMER PRINT "Generating map, please wait..." InitMap Map(), W CLS 'DebugMap Map(), W FOR T = 0 TO 500 STEP 32 DisplayMap Map(), W, (T), DEG \ 64, 96 NEXT SYSTEM
SUB DebugMap (Map() AS INTEGER, W AS INTEGER) DIM I AS INTEGER, J AS INTEGER
'FOR J = 0 TO W - 1 ' FOR I = 0 TO W * 8 - 1 ' LINE (I * 3, J * 3)-STEP(2, 2), Map(I, J), BF ' NEXT 'NEXT
FOR S = 0 TO 3 FOR J = 0 TO W - 1 FOR I = 0 TO J * 2 LINE ((S * (W * 2 - 1) + I - J) * 3, J * 3)-STEP(2, 2), Map(S * W * 2 + I, J), BF LINE ((S * (W * 2 - 1) + I - J) * 3, (W * 2 - J - 1) * 3)-STEP(2, 2), Map(S * W * 2 + W * 2 - I - 1, W - J - 1), BF NEXT NEXT NEXT
END SUB
SUB DisplayMap (Map() AS INTEGER, W AS INTEGER, T AS INTEGER, D AS INTEGER, R AS INTEGER)
DIM V(0 TO W) AS INTEGER DIM I AS INTEGER, X0 AS INTEGER DIM X AS INTEGER, Y AS INTEGER DIM S AS INTEGER, YR AS INTEGER DIM Quad AS INTEGER, P AS INTEGER
FOR I = 0 TO W V(I) = R * SIN(I / W / 2 * Pi) NEXT
FOR I = 0 TO W - 1 FOR Y = V(I) TO V(I + 1) - 1 IF V(I + 1) > V(I) THEN YR = DEG \ 4 - (Y - V(I)) / (V(I + 1) - V(I)) * DEG \ 4 ELSE YR = 0 X0 = SQR(R * R - Y * Y)
FOR X = 0 TO X0 - 1
S = ATN(X / SQR(X0 * X0 - X * X)) * DEG / (Pi * 2)
P = GetPoint(W, I, YR, T - S - D, Quad) PSET (CX + 5 + R - X, CY - Y), Map(Quad * W * 2 + P, W - I - 1) PSET (CX + 5 + R - X, CY + Y), Map((Quad + 1) * W * 2 - P - 1, I)
P = GetPoint(W, I, YR, T + S - D, Quad) PSET (CX + 5 + R + X, CY - Y), Map(Quad * W * 2 + P, W - I - 1) PSET (CX + 5 + R + X, CY + Y), Map((Quad + 1) * W * 2 - P - 1, I)
P = GetPoint(W, I, YR, T - S + D, Quad) PSET (CX - 5 - R - X, CY - Y), Map(Quad * W * 2 + P, W - I - 1) PSET (CX - 5 - R - X, CY + Y), Map((Quad + 1) * W * 2 - P - 1, I)
P = GetPoint(W, I, YR, T + S + D, Quad) PSET (CX - 5 - R + X, CY - Y), Map(Quad * W * 2 + P, W - I - 1) PSET (CX - 5 - R + X, CY + Y), Map((Quad + 1) * W * 2 - P - 1, I)
NEXT
NEXT NEXT
END SUB
FUNCTION GetPoint% (W AS INTEGER, Level AS INTEGER, YR AS INTEGER, Angle AS INTEGER, Quad AS INTEGER)
DIM T AS INTEGER, F AS INTEGER, I AS INTEGER
Angle = (Angle + DEG) MOD DEG
T = Angle MOD (DEG \ 4) Quad = Angle \ (DEG \ 4) F = T * (W - 1 - Level)
I = 2 * (F \ (DEG \ 4)) F = 2 * (F MOD (DEG \ 4))
GetPoint% = I - (F >= YR) - (F >= DEG \ 2 - YR)
END FUNCTION
SUB InitMap (Map() AS INTEGER, W AS INTEGER) DIM I AS INTEGER, J AS INTEGER
DIM C AS INTEGER
FOR J = 0 TO W - 1 FOR I = 0 TO W * 8 - 1 Map(I, J) = INT(RND * 450) NEXT NEXT
FOR C = 1 TO 16
FOR J = 0 TO W - 1 FOR I = J AND 3 TO W * 8 - 1 STEP 4 GOSUB Blend NEXT NEXT FOR J = 0 TO W - 1 FOR I = (J + 2) AND 3 TO W * 8 - 1 STEP 4 GOSUB Blend NEXT NEXT FOR J = 0 TO W - 1 FOR I = (J + 3) AND 3 TO W * 8 - 1 STEP 4 GOSUB Blend NEXT NEXT FOR J = 0 TO W - 1 FOR I = (J + 1) AND 3 TO W * 8 - 1 STEP 4 GOSUB Blend NEXT NEXT
NEXT
FOR J = 0 TO W - 1 FOR I = 0 TO W * 8 - 1 Map(I, J) = ((Map(I, J) \ 8) MOD 15) + 1 NEXT NEXT
EXIT SUB
Blend: T = I MOD (W * 2) S = I \ (W * 2)
Acc = 0 N = 4 'Upper half (of sphere) IF J * 2 >= T THEN
'Down-pointing triangles IF T AND 1 THEN Acc = Acc + Map(I - 1, J - 1) + Map(I - 1, J) + Map(I + 1, J) ELSE
'Left Edge IF T = 0 THEN Acc = Acc + 2 * Map(((S + 3) MOD 4) * W * 2 + J * 2, J) N = N + 1 ELSE Acc = Acc + Map(I - 1, J) END IF
'Right Edge IF T = J * 2 THEN Acc = Acc + 2 * Map(((S + 1) MOD 4) * W * 2, J) N = N + 1 ELSE Acc = Acc + Map(I + 1, J) END IF
'Bottom edge IF J = W - 1 THEN Acc = Acc + Map(S * W * 2 + W * 2 - T - 1, 0) ELSE Acc = Acc + Map(I + 1, J + 1) END IF END IF
ELSE
'Down-pointing triangles IF T AND 1 THEN
'Left Edge IF T = J * 2 + 1 THEN Acc = Acc + 2 * Map(((S + 1) MOD 4) * W * 2 + W - 1, J) N = N + 1 ELSE Acc = Acc + Map(I - 1, J) END IF
'Right Edge IF T = W * 2 - 1 THEN Acc = Acc + 2 * Map(((S + 3) MOD 4) * W * 2 + J * 2 + 1, J) N = N + 1 ELSE Acc = Acc + Map(I + 1, J) END IF
'Top Edge IF J = 0 THEN Acc = Acc + Map(S * W * 2 + W * 2 - T - 1, W - 1) ELSE Acc = Acc + Map(I - 1, J - 1) END IF
SUB InitPal 'Fixes occasional SCREEN 12 DAC/palette issues DIM I AS INTEGER I = INP(&H3DA) FOR I = 0 TO 15 OUT &H3C0, I OUT &H3C0, I NEXT OUT &H3C0, 32 END SUB
SUB Pal (Index AS INTEGER, Red AS INTEGER, Green AS INTEGER, Blue AS INTEGER) OUT &H3C8, Index OUT &H3C9, Red OUT &H3C9, Green OUT &H3C9, Blue END SUB
Obviously it's part of a boycott against MS products
July 13 2008, 4:06 PM
Seriously though, stupid N54 inserts <BR>s in a <PRE>, but leaves the regular line breaks. Since <PRE>s preserve line breaks, this means everything is double-spaced.
So I wrote myself a little utility to remove all line breaks and put <BR>s in manually, and also replace *s with an HTML escape code. But stupid IE, it turns out, displays the <BR>s but doesn't copy them out. Looks like it's time for Plan B: a Javascript routine that strips all <BR>s from within <PRE>s.
It was well worth the trouble of making a program out of the hash that IE gave me (figuring out where all the line breaks were), but once I got it running, crossed my eyes, it was perfect! I can't believe how perfectly round the planet is.
Naturally, in DOSBox, it took a long time to generate the map and was much too slow to see the planet rotating (that would have been great!). But even with all the problems, it was worth it to see that perfect sphere (I was a little over 2 feet from the monitor when it "locked").
Replace the main module from "SCREEN 12" to "SYSTEM" with the following code. It generates 16 BSAVE'd files the first time you run the program, and after that just runs the animation using those files (begins instantly).
NOTE: First time you run the program, it may take awhile. Don't bail until you see the planets rotating smoothly.
-Bob
'Copy code from here ------------------------------------
DIM PlanetARRAY(1 TO 19500) AS INTEGER
SCREEN 12
InitPal
Pal 1, 0, 2, 58
Pal 2, 6, 12, 60
Pal 3, 13, 16, 60
Pal 4, 63, 60, 45
Pal 5, 33, 31, 26
Pal 6, 20, 51, 20
Pal 7, 21, 46, 10
Pal 8, 1, 26, 2
Pal 9, 4, 20, 0
Pal 10, 24, 24, 24
Pal 11, 44, 44, 45
Pal 12, 31, 29, 21
Pal 13, 9, 42, 5
Pal 14, 2, 40, 3
Pal 15, 2, 12, 50
OPEN "Planet1.BSV" FOR BINARY AS #1
IF LOF(1) = 0 THEN
CLOSE #1
PRINT "Generating map, please wait..."
InitMap Map(), W
CLS
DEF SEG = VARSEG(PlanetARRAY(1))
FOR T = 0 TO 500 STEP 32
DisplayMap Map(), W, (T), DEG \ 64, 96
GET (120, 145)-(520, 335), PlanetARRAY
FileCOUNT = FileCOUNT + 1
FileNAME$ = "Planet" + LTRIM$(STR$(FileCOUNT)) + ".BSV"
BSAVE FileNAME$, VARPTR(PlanetARRAY(1)), 39000
NEXT
DEF SEG
ELSE
CLOSE #1
END IF
DEF SEG = VARSEG(PlanetARRAY(1))
FileCOUNT = 0
DO
FileCOUNT = FileCOUNT + 1
IF FileCOUNT = 17 THEN FileCOUNT = 1
FileNAME$ = "Planet" + LTRIM$(STR$(FileCOUNT)) + ".BSV"
BLOAD FileNAME$, VARPTR(PlanetARRAY(1))
StartTIME! = TIMER
DO: LOOP UNTIL TIMER > StartTIME! + .2
WAIT &H3DA, 8: WAIT &H3DA, 8, 8
PUT (120, 145), PlanetARRAY, PSET
LOOP WHILE INKEY$ = ""
DEF SEG
SYSTEM
