After making some adjustments, here's a flat earth with a sky globe around it. With a slanted roof office building inside.
I put grid lines on the sky just as a test. They get weird at the poles for some reason. (Edit: the sphere resolution is low at lines 81&82. Increase to 72 for smoother globe)
I put grid lines on the sky just as a test. They get weird at the poles for some reason. (Edit: the sphere resolution is low at lines 81&82. Increase to 72 for smoother globe)
Code: (Select All)
'3d globe with office - james2464 - Dec 20 2022
'Credit to 3D program and tutorial by MasterGy
Option _Explicit
Randomize Timer
Screen _NewImage(1000, 1000, 32)
Const pip180 = 3.141592 / 180
Dim Shared c(100) As Long
Dim floor1b, wall1b, wall2b, ceiling1b, ground1b, sky1b
Dim scr, da, db, da2, dega, db2, degb, ss, ap, sqa, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
Dim sky_points, sky_image
Dim actual_point, asq
Dim wx0, wy0, wz0, wx1, wy1, wz1, wx2, wy2, wz2, wx3, wy3, wz3, sx0, sy0, sx1, sy1, sx2, sy2, sx3, sy3
Dim mousex, mousey, mw, mouse_sens, vec_x, vec_y, vec_z, speed, moving
Cls
colour1
Dim Shared floor1, wall1, wall2, ceiling1, ground1, sky1
'create floor image
floor1 = _NewImage(500, 500, 32)
makefloor
'create wall1 image
wall1 = _NewImage(500, 100, 32)
makewall
'create wall2 image
wall2 = _NewImage(500, 100, 32)
makewall2
'create ceiling image
ceiling1 = _NewImage(500, 500, 32)
makeceiling
'create ground image
ground1 = _NewImage(500, 500, 32)
makeground
'create sky image
sky1 = _NewImage(750, 750, 32)
makesky
floor1b = _CopyImage(floor1, 33)
wall1b = _CopyImage(wall1, 33)
wall2b = _CopyImage(wall2, 33)
ceiling1b = _CopyImage(ceiling1, 33)
ground1b = _CopyImage(ground1, 33)
sky1b = _CopyImage(sky1, 33)
'create spectator
Dim Shared sp(6)
sp(0) = 0 'X position
sp(1) = 0 'Y
sp(2) = 450 'Z
sp(3) = 0 'looking in the direction of the observer XZ
sp(4) = 0 'looking in the direction of the observer YZ
sp(5) = 1 'multiplier X-Y see
sp(6) = 1 'multiplier Z see
'create screen
scr = _NewImage(1000, 1000 / _DesktopWidth * _DesktopHeight, 32)
Screen scr
_MouseHide
_FullScreen
_Dest scr
_DisplayOrder _Hardware , _Software
'sky install *********************************************************************************
da = 16 'resolution sphere X
db = 16 'resolution sphere Y
sky_points = da * db
Dim sky_points(sky_points - 1, 9), sq(sky_points - 1, 7)
'sky_image = _LoadImage("sky.jpg", 33)
sky_image = _CopyImage(sky1, 33)
For da2 = 0 To da - 1
dega = 360 / (da - 1) * da2 * pip180
For db2 = 0 To db - 1
degb = 180 / (db - 1) * db2 * pip180
ss = 1500
ap = da2 * db + db2
sky_points(ap, 0) = Sin(degb) * Cos(dega) * ss
sky_points(ap, 1) = Sin(degb) * Sin(dega) * ss
sky_points(ap, 2) = Cos(degb) * ss
Next db2
Next da2
For da2 = 0 To da - 2
For db2 = 0 To db - 2
sqa = da2 * db + db2
sq(sqa, 0) = sqa
sq(sqa, 1) = sq(sqa, 0) + 1
sq(sqa, 2) = sq(sqa, 0) + db
sq(sqa, 3) = sq(sqa, 2) + 1
sq(sqa, 4) = _Width(sky_image) - (_Width(sky_image) / (da - 1) * da2) - 1
sq(sqa, 5) = _Width(sky_image) - (_Width(sky_image) / (da - 1) * (da2 + 1)) - 1
sq(sqa, 6) = Int(_Height(sky_image) / (db - 1) * db2)
sq(sqa, 7) = Int(_Height(sky_image) / (db - 1) * (db2 + 1))
Next db2
Next da2
'*********************************************************************************************
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
Do
_Limit 40
'_PutImage (1, 1), sky_image 'background
'floor
x1 = -250: y1 = -250: z1 = 500: r2m x1, y1, z1: x2 = 250: y2 = -250: z2 = 500: r2m x2, y2, z2
x3 = -250: y3 = 250: z3 = 500: r2m x3, y3, z3: x4 = 250: y4 = 250: z4 = 500: r2m x4, y4, z4
maptexture floor1b, 500, 500, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
'wall 1
x1 = -250: y1 = -250: z1 = 400: r2m x1, y1, z1: x2 = 250: y2 = -250: z2 = 400: r2m x2, y2, z2
x3 = -250: y3 = -250: z3 = 500: r2m x3, y3, z3: x4 = 250: y4 = -250: z4 = 500: r2m x4, y4, z4
maptexture wall2b, 500, 100, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
'wall 2
x1 = 250: y1 = 250: z1 = 400: r2m x1, y1, z1: x2 = -250: y2 = 250: z2 = 400: r2m x2, y2, z2
x3 = 250: y3 = 250: z3 = 500: r2m x3, y3, z3: x4 = -250: y4 = 250: z4 = 500: r2m x4, y4, z4
maptexture wall2b, 500, 100, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
'wall 3
x1 = 250: y1 = -250: z1 = 300: r2m x1, y1, z1: x2 = 250: y2 = 250: z2 = 400: r2m x2, y2, z2
x3 = 250: y3 = -250: z3 = 500: r2m x3, y3, z3: x4 = 250: y4 = 250: z4 = 500: r2m x4, y4, z4
maptexture wall1b, 500, 100, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
'wall 4
x1 = -250: y1 = 250: z1 = 400: r2m x1, y1, z1: x2 = -250: y2 = -250: z2 = 300: r2m x2, y2, z2
x3 = -250: y3 = 250: z3 = 500: r2m x3, y3, z3: x4 = -250: y4 = -250: z4 = 500: r2m x4, y4, z4
maptexture wall1b, 500, 100, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
'ceiling
x1 = -250: y1 = -250: z1 = 300: r2m x1, y1, z1: x2 = 250: y2 = -250: z2 = 300: r2m x2, y2, z2
x3 = -250: y3 = 250: z3 = 400: r2m x3, y3, z3: x4 = 250: y4 = 250: z4 = 400: r2m x4, y4, z4
maptexture ceiling1b, 500, 500, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
'ground
x1 = -1500: y1 = -1500: z1 = 502: r2m x1, y1, z1: x2 = 1500: y2 = -1500: z2 = 502: r2m x2, y2, z2
x3 = -1500: y3 = 1500: z3 = 502: r2m x3, y3, z3: x4 = 1500: y4 = 1500: z4 = 502: r2m x4, y4, z4
maptexture ground1b, 500, 500, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
'wall 5 - above wall 1
x1 = -250: y1 = -250: z1 = 300: r2m x1, y1, z1: x2 = 250: y2 = -250: z2 = 300: r2m x2, y2, z2
x3 = -250: y3 = -250: z3 = 400: r2m x3, y3, z3: x4 = 250: y4 = -250: z4 = 400: r2m x4, y4, z4
maptexture wall1b, 500, 100, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
'draw sky *********************************************************************************
'rotating
For actual_point = 0 To sky_points - 1
sky_points(actual_point, 4) = sky_points(actual_point, 0)
sky_points(actual_point, 5) = sky_points(actual_point, 1)
sky_points(actual_point, 6) = sky_points(actual_point, 2)
r2m sky_points(actual_point, 4), sky_points(actual_point, 5), sky_points(actual_point, 6)
Next actual_point
For asq = 0 To sky_points - 1
wx0 = sky_points(sq(asq, 0), 4) + 0: wy0 = sky_points(sq(asq, 0), 5) + 0: wz0 = sky_points(sq(asq, 0), 6)
wx1 = sky_points(sq(asq, 1), 4) + 0: wy1 = sky_points(sq(asq, 1), 5) + 0: wz1 = sky_points(sq(asq, 1), 6)
wx2 = sky_points(sq(asq, 2), 4) + 0: wy2 = sky_points(sq(asq, 2), 5) + 0: wz2 = sky_points(sq(asq, 2), 6)
wx3 = sky_points(sq(asq, 3), 4) + 0: wy3 = sky_points(sq(asq, 3), 5) + 0: wz3 = sky_points(sq(asq, 3), 6)
sy0 = sq(asq, 6): sx0 = sq(asq, 4): sy1 = sq(asq, 7): sx1 = sq(asq, 4): sy2 = sq(asq, 6): sx2 = sq(asq, 5): sy3 = sq(asq, 7): sx3 = sq(asq, 5)
_MapTriangle (sx0, sy0)-(sx1, sy1)-(sx2, sy2), sky_image To(wx0, wy0, wz0)-(wx1, wy1, wz1)-(wx2, wy2, wz2), , _Smooth
_MapTriangle (sx3, sy3)-(sx1, sy1)-(sx2, sy2), sky_image To(wx3, wy3, wz3)-(wx1, wy1, wz1)-(wx2, wy2, wz2), , _Smooth
Next asq
' ****************************************************************************************************
'_MapTriangle (0, 0)-(x, 0)-(0, y), image1 To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
'_MapTriangle (x, y)-(x, 0)-(0, y), image1 To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
_Display
'-------------------------------------------------------------
'mouse input axis movement and mousewheel
'-------------------------------------------------------------
mousex = mousex * .6
mousey = mousey * .6
mw = 0
While _MouseInput: mousex = mousex + _MouseMovementX: mousey = mousey + _MouseMovementY: mw = mw + _MouseWheel: Wend 'movement data read
'control spectator
mouse_sens = .0007 'mouse rotating sensitive
sp(3) = sp(3) - mousex * mouse_sens
sp(4) = sp(4) + mousey * mouse_sens
If Abs(sp(4)) > _Pi / 2 Then sp(4) = _Pi / 2 * Sgn(sp(4))
vec_x = (Sin(sp(3)) * (Cos(sp(4) + _Pi)))
vec_y = (Cos(sp(3)) * (Cos(sp(4) + _Pi)))
vec_z = -Sin(sp(4) + _Pi)
speed = 6 'moving speed
moving = Abs(_MouseButton(1) Or _KeyDown(Asc("w"))) * speed - Abs(_MouseButton(2) Or _KeyDown(Asc("s"))) * speed
sp(0) = sp(0) + vec_x * moving
sp(1) = sp(1) + vec_y * moving
sp(2) = sp(2) + vec_z * moving
'If sp(0) > 465 Then sp(0) = 465
'If sp(1) > 465 Then sp(1) = 465
'If sp(0) < 35 Then sp(0) = 35
'If sp(1) < 35 Then sp(1) = 35
Loop Until _KeyDown(27)
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
Sub rot2 (x, y, ang)
Dim x1, y1
x1 = x * Cos(ang) - y * Sin(ang)
y1 = x * Sin(ang) + y * Cos(ang)
x = x1: y = y1
End Sub
Sub r2m (x, y, z)
Dim x2, y2, z2
x2 = x - sp(0)
y2 = y - sp(1)
z2 = z - sp(2)
rotate_2d x2, y2, sp(3)
rotate_2d y2, z2, sp(4) + _Pi / 2
x = x2 * sp(5)
y = y2 * sp(5)
z = z2 * sp(6)
End Sub
Sub rotate_2d (x, y, ang)
Dim x1, y1
x1 = x * Cos(ang) - y * Sin(ang)
y1 = x * Sin(ang) + y * Cos(ang)
x = x1: y = y1
End Sub
Sub colour1
c(0) = _RGB(0, 0, 0)
c(1) = _RGB(255, 255, 255)
c(2) = _RGB(85, 45, 0)
c(3) = _RGB(0, 45, 85)
c(4) = _RGB(40, 60, 0)
c(5) = _RGB(0, 25, 75)
c(6) = _RGB(75, 25, 0)
c(7) = _RGB(150, 130, 0)
c(8) = _RGB(150, 150, 250)
c(9) = _RGB(250, 150, 150)
c(10) = _RGB(150, 250, 150)
c(11) = _RGB(150, 150, 255)
c(12) = _RGB(40, 30, 0)
c(13) = _RGB(255, 0, 0)
c(14) = _RGB(50, 150, 50)
c(15) = _RGB(155, 155, 155)
c(16) = _RGB(165, 165, 165)
c(17) = _RGB(175, 175, 175)
c(18) = _RGB(100, 100, 100)
c(20) = _RGB(40, 40, 10)
End Sub
Sub makefloor
Dim t, x1, y1
Cls
Line (0, 0)-(500, 500), c(18), BF 'floor background
For t = 1 To 6000
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(0)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(2)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(3)
Next t
_Display
_PutImage (0, 0)-(500, 500), 0, floor1, (0, 0)-(500, 500)
'Sleep
End Sub
Sub makewall
Dim t, x1, y1
Cls
Line (0, 0)-(500, 100), c(15), BF 'wall background
For t = 1 To 6000
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(16)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(17)
Next t
_Display
_PutImage (0, 0)-(500, 100), 0, wall1, (0, 0)-(500, 100)
_ClearColor c(0), wall1
'Sleep
End Sub
Sub makewall2
Dim t, x1, y1
Cls
Line (0, 0)-(500, 100), c(15), BF 'wall2 background
For t = 1 To 6000
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(16)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(17)
Next t
Line (70, 25)-(150, 75), c(0), BF
Line (210, 25)-(290, 75), c(0), BF
Line (350, 25)-(430, 75), c(0), BF
_Display
_PutImage (0, 0)-(500, 100), 0, wall2, (0, 0)-(500, 100)
_ClearColor c(0), wall2
'Sleep
End Sub
Sub makeceiling
Dim t, t2
Cls
Line (0, 0)-(500, 500), c(18), BF 'ceiling background
Line (2, 2)-(498, 498), c(17), BF 'ceiling light background
For t = 26 To 540 Step 32
Line (t - 1, 0)-(t, 500), c(18), BF
Line (0, t - 1)-(500, t), c(18), BF
Next t
For t = 32 To 470 Step 128
For t2 = 32 To 470 Step 128
Paint (t, t2), c(1), c(18)
Next t2
Next t
_Display
_PutImage (0, 0)-(500, 500), 0, ceiling1, (0, 0)-(500, 500)
_ClearColor c(0), ceiling1
'Sleep
End Sub
Sub makeground
Dim t, x1, y1
Cls
Line (0, 0)-(500, 500), c(20), BF 'ground background
For t = 1 To 6000
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(0)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(2)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(3)
Next t
_Display
_PutImage (0, 0)-(500, 500), 0, ground1, (0, 0)-(500, 500)
'Sleep
End Sub
Sub makesky
Dim t, x1, y, m, r
Cls
y = 750
For t = 1 To y
m = 255 * ((750 - t * .95) / 750)
c(99) = _RGBA(180, 180, 255, m)
Line (0, t)-(750, t), c(99)
Next t
For t = 0 To 750 Step 25 'longituge lines
Line (t, 0)-(t, 750), c(1)
Next t
For t = 0 To 750 Step 25 'latitude lines
Line (0, t)-(750, t), c(1)
Next t
_Display
_PutImage (0, 0)-(750, 750), 0, sky1, (0, 0)-(750, 750)
'Sleep
End Sub
Sub maptexture (image1, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
_MapTriangle (0, 0)-(x, 0)-(0, y), image1 To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
_MapTriangle (x, y)-(x, 0)-(0, y), image1 To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
End Sub