12-19-2022, 06:01 AM
I tried to make some kind of empty office building. Also condensed the code a bit.
This allows walking, not floating. And you can't go through the walls. (or comment/delete lines 146-149)
This allows walking, not floating. And you can't go through the walls. (or comment/delete lines 146-149)
Code: (Select All)
'3d Room - james2464 - Dec 18 2022
'Credit to 3D program and tutorial by MasterGy
Randomize Timer
Screen _NewImage(1000, 600, 32)
Dim Shared c(100) As Long
bgspace = _NewImage(1000, 600, 32)
Line (1, 1)-(1000, 600), _RGB(120, 120, 180), BF
_PutImage (1, 1)-(1000, 600), 0, bgspace, (1, 1)-(1000, 600)
Cls
colour1
Dim Shared floor1, wall1, wall2, ceiling1, ground1
'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
bgspace2 = _CopyImage(bgspace, 33)
tile = _CopyImage(floatingtiles, 33)
floor1b = _CopyImage(floor1, 33)
wall1b = _CopyImage(wall1, 33)
wall2b = _CopyImage(wall2, 33)
ceiling1b = _CopyImage(ceiling1, 33)
ground1b = _CopyImage(ground1, 33)
'create spectator
Dim Shared sp(6)
sp(0) = 250 'X position
sp(1) = 250 '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
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
'=============================================================================================================
Do
_Limit 40
_PutImage (1, 1), bgspace2 'background
'floor
x1 = 0: y1 = 0: z1 = 500: r2m x1, y1, z1: x2 = 500: y2 = 0: z2 = 500: r2m x2, y2, z2
x3 = 0: y3 = 500: z3 = 500: r2m x3, y3, z3: x4 = 500: y4 = 500: 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 = 0: y1 = 0: z1 = 400: r2m x1, y1, z1: x2 = 500: y2 = 0: z2 = 400: r2m x2, y2, z2
x3 = 0: y3 = 0: z3 = 500: r2m x3, y3, z3: x4 = 500: y4 = 0: 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 = 500: y1 = 500: z1 = 400: r2m x1, y1, z1: x2 = 0: y2 = 500: z2 = 400: r2m x2, y2, z2
x3 = 500: y3 = 500: z3 = 500: r2m x3, y3, z3: x4 = 0: y4 = 500: 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 = 500: y1 = 0: z1 = 400: r2m x1, y1, z1: x2 = 500: y2 = 500: z2 = 400: r2m x2, y2, z2
x3 = 500: y3 = 0: z3 = 500: r2m x3, y3, z3: x4 = 500: y4 = 500: 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 = 0: y1 = 500: z1 = 400: r2m x1, y1, z1: x2 = 0: y2 = 0: z2 = 400: r2m x2, y2, z2
x3 = 0: y3 = 500: z3 = 500: r2m x3, y3, z3: x4 = 0: y4 = 0: z4 = 500: r2m x4, y4, z4
maptexture wall1b, 500, 100, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
'ceiling
x1 = 0: y1 = 0: z1 = 400: r2m x1, y1, z1: x2 = 500: y2 = 0: z2 = 400: r2m x2, y2, z2
x3 = 0: y3 = 500: z3 = 400: r2m x3, y3, z3: x4 = 500: y4 = 500: 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 = 2000: y2 = -1500: z2 = 502: r2m x2, y2, z2
x3 = -1500: y3 = 2000: z3 = 502: r2m x3, y3, z3: x4 = 2000: y4 = 2000: z4 = 502: r2m x4, y4, z4
maptexture ground1b, 500, 500, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
_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 = 2 '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 r2m (x, y, z)
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)
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
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
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
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
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
_Display
_PutImage (0, 0)-(500, 500), 0, ceiling1, (0, 0)-(500, 500)
_ClearColor c(0), ceiling1
'Sleep
End Sub
Sub makeground
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 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