Posts: 230
Threads: 25
Joined: Aug 2022
Reputation:
23
Found some used office furniture for really cheap! Sort of a mess right now, but I'll organize it soon.
(figuring out how to create objects and copy/paste them easily)
Code: (Select All) '3d globe with office - james2464 - Dec 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 scr, da, db, da2, dega, db2, degb, ss, ap, sqa
Dim sky_points, sky_image, 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
Dim sp3
Dim Shared bx(8, 3), fx, obj(100, 4)
Dim t
fx = 0
Cls
colour1
Dim Shared floor1, wall1, wall2, ceiling1, ground1, sky1, box1, cbx(20)
floor1 = _NewImage(500, 500, 32): makefloor
wall1 = _NewImage(500, 100, 32): makewall
wall2 = _NewImage(500, 100, 32): makewall2
ceiling1 = _NewImage(500, 500, 32): makeceiling
ground1 = _NewImage(500, 500, 32): makeground
sky1 = _NewImage(750, 750, 32): makesky
box1 = _NewImage(500, 500, 32): makebox
Dim Shared box1b: box1b = _CopyImage(box1, 33)
For t = 0 To 10: cbx(t) = _NewImage(400, 400, 32): Next t: makepallette
'moving box starting position points
bx(1, 1) = -5: bx(1, 2) = -120: bx(1, 3) = 350: bx(2, 1) = -5: bx(2, 2) = -120: bx(2, 3) = 340
bx(3, 1) = 5: bx(3, 2) = -120: bx(3, 3) = 350: bx(4, 1) = 5: bx(4, 2) = -120: bx(4, 3) = 340
bx(5, 1) = -5: bx(5, 2) = -110: bx(5, 3) = 340: bx(6, 1) = 5: bx(6, 2) = -110: bx(6, 3) = 340
bx(7, 1) = -5: bx(7, 2) = -110: bx(7, 3) = 350: bx(8, 1) = 5: bx(8, 2) = -110: bx(8, 3) = 350
Dim Shared tximage(200)
For t = 0 To 10: tximage(t) = _CopyImage(cbx(t), 33): Next t
tximage(10) = _CopyImage(floor1, 33)
tximage(11) = _CopyImage(ground1, 33)
tximage(12) = _CopyImage(wall1, 33) 'office wall solid
tximage(13) = _CopyImage(wall2, 33) 'office wall with 3 windows
tximage(14) = _CopyImage(ceiling1, 33) 'office ceiling
Type mapobject
n As Integer 'object number
x As Single 'x origin
y As Single 'y origin
z As Single 'z origin
x1 As Single
y1 As Single
z1 As Single
x2 As Single
y2 As Single
z2 As Single
x3 As Single
y3 As Single
z3 As Single
x4 As Single
y4 As Single
z4 As Single
ix As Single 'image x
iy As Single 'image y
in As Integer 'image number - tximage()
End Type
Dim Shared raw(100) As mapobject, oo(900) As mapobject
'create texture point data array
Dim Shared tx(500, 19), ttx, txtot, objtot
'objects and data points
Data 1,0,0,0,-250,-250,0,250,-250,0,-250,250,0,250,250,0,500,500,10: 'floor
Data 2,0,0,0,-500,-500,0,500,-500,0,-500,500,0,500,500,0,500,500,11: 'ground
Data 3,0,0,0,-250,0,-50,250,0,-50,-250,0,50,250,0,50,500,100,13: 'wall
Data 4,0,0,0,250,0,-50,-250,0,-50,250,0,50,-250,0,50,500,100,13: 'wall
Data 5,0,0,0,0,-250,-100,0,250,-100,0,-250,100,0,250,100,500,100,13: 'wall
Data 6,0,0,0,0,250,-100,0,-250,-100,0,250,100,0,-250,100,500,100,13: 'wall
Data 7,0,0,0,-250,0,-50,250,0,-50,-250,0,50,250,0,50,500,100,13: 'wall
Data 8,0,0,0,250,0,-50,-250,0,-50,250,0,50,-250,0,50,500,100,13: 'wall
Data 9,0,0,0,-250,-250,0,250,-250,0,-250,250,0,250,250,0,500,500,14: 'ceiling
Data 10,0,0,0,-250,-250,0,250,-250,0,-250,250,0,250,250,0,500,500,2: 'roof
Data 11,0,0,0,-60,1,0,60,1,0,-60,1,90,60,1,90,500,100,8: 'divider side
Data 11,0,0,0,-60,-1,0,60,-1,0,-60,-1,90,60,-1,90,500,100,8: 'side
Data 11,0,0,0,-60,1,0,-60,-1,0,60,1,0,60,-1,0,500,100,9: 'edge
Data 11,0,0,0,60,1,0,60,-1,0,60,1,90,60,-1,90,500,100,9: 'edge
Data 12,0,0,0,20,50,0,20,-50,0,-20,50,0,-20,-50,0,200,200,2: 'desk top 1
Data 12,0,0,0,20,50,2,20,-50,2,-20,50,2,-20,-50,2,200,200,2: 'top 2
Data 12,0,0,0,-20,50,2,-20,50,0,20,50,2,20,50,0,200,200,6: 'top end edge
Data 12,0,0,0,-20,-50,2,-20,-50,0,20,-50,2,20,-50,0,200,200,6: 'top end edge
Data 12,0,0,0,20,-50,2,20,50,2,20,-50,0,20,50,0,200,200,6: 'top side edge
Data 12,0,0,0,-20,-50,2,-20,50,2,-20,-50,0,-20,50,0,200,200,6: 'top side edge
Data 12,0,0,0,17,47,2,19,47,2,17,47,30,19,47,30,200,200,2: 'leg 1a
Data 12,0,0,0,17,49,2,19,49,2,17,49,30,19,49,30,200,200,2: 'leg 1b
Data 12,0,0,0,17,49,2,17,47,2,17,49,30,17,47,30,200,200,6: 'leg 1c
Data 12,0,0,0,19,49,2,19,47,2,19,49,30,19,47,30,200,200,6: 'leg 1d
Data 12,0,0,0,17,-47,2,19,-47,2,17,-47,30,19,-47,30,200,200,2: 'leg 2a
Data 12,0,0,0,17,-49,2,19,-49,2,17,-49,30,19,-49,30,200,200,2: 'leg 2b
Data 12,0,0,0,17,-49,2,17,-47,2,17,-49,30,17,-47,30,200,200,6: 'leg 2c
Data 12,0,0,0,19,-49,2,19,-47,2,19,-49,30,19,-47,30,200,200,6: 'leg 2d
Data 12,0,0,0,-19,49,2,-17,49,2,-19,49,30,-17,49,30,200,200,2: 'leg 3a
Data 12,0,0,0,-19,47,2,-17,47,2,-19,47,30,-17,47,30,200,200,2: 'leg 3b
Data 12,0,0,0,-19,47,2,-19,49,2,-19,47,30,-19,49,30,200,200,6: 'leg 3c
Data 12,0,0,0,-17,47,2,-17,49,2,-17,47,30,-17,49,30,200,200,6: 'leg 3d
Data 12,0,0,0,-19,-47,2,-17,-47,2,-19,-47,30,-17,-47,30,200,200,2: 'leg 4a
Data 12,0,0,0,-19,-49,2,-17,-49,2,-19,-49,30,-17,-49,30,200,200,2: 'leg 4b
Data 12,0,0,0,-19,-49,2,-19,-47,2,-19,-49,30,-19,-47,30,200,200,6: 'leg 4c
Data 12,0,0,0,-17,-49,2,-17,-47,2,-17,-49,30,-17,-47,30,200,200,6: 'leg 4d
txtot = 36
'read data into array tx()
Dim t2, ct1, ct2, ct3
For t = 1 To txtot
For t2 = 1 To 19
Read tx(t, t2)
Next t2
'create 'raw' objects
raw(t).n = tx(t, 1): raw(t).x = tx(t, 2): raw(t).y = tx(t, 3): raw(t).z = tx(t, 4)
raw(t).x1 = tx(t, 5): raw(t).y1 = tx(t, 6): raw(t).z1 = tx(t, 7)
raw(t).x2 = tx(t, 8): raw(t).y2 = tx(t, 9): raw(t).z2 = tx(t, 10)
raw(t).x3 = tx(t, 11): raw(t).y3 = tx(t, 12): raw(t).z3 = tx(t, 13)
raw(t).x4 = tx(t, 14): raw(t).y4 = tx(t, 15): raw(t).z4 = tx(t, 16)
raw(t).ix = tx(t, 17): raw(t).iy = tx(t, 18): raw(t).in = tx(t, 19)
Next t
'object copies
Dim nn, nc, xc, yc, zc, ac, ct
nn = 1: nc = 1: xc = 0: yc = 0: zc = 500: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'floor
nn = 1: nc = 2: xc = 0: yc = 0: zc = 502: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'ground
nn = 1: nc = 3: xc = 0: yc = -250: zc = 450: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 4: xc = 0: yc = 250: zc = 450: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 5: xc = 250: yc = 0: zc = 400: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 6: xc = -250: yc = 0: zc = 400: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 7: xc = 0: yc = -250: zc = 350: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 8: xc = 0: yc = 250: zc = 350: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 9: xc = 0: yc = 0: zc = 300: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'ceiling
nn = 1: nc = 10: xc = 0: yc = 0: zc = 299: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'roof
nn = 1: nc = 11: xc = -190: yc = -70: zc = 410: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'divider
nn = 1: nc = 12: xc = -190: yc = -40: zc = 470: ac = 1.571: objectcopy nn, nc, xc, yc, zc, ac 'desk
nn = 1: nc = 12: xc = -190: yc = -100: zc = 470: ac = 1.571: objectcopy nn, nc, xc, yc, zc, ac 'desk
nn = 1: nc = 11: xc = 190: yc = 70: zc = 410: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'divider
nn = 1: nc = 12: xc = 190: yc = 40: zc = 470: ac = 1.571: objectcopy nn, nc, xc, yc, zc, ac 'desk
nn = 1: nc = 12: xc = 190: yc = 100: zc = 470: ac = 1.571: objectcopy nn, nc, xc, yc, zc, ac 'desk
nn = 1: nc = 12: xc = 0: yc = 140: zc = 470: ac = -.3: objectcopy nn, nc, xc, yc, zc, ac 'desk
nn = 1: nc = 12: xc = 40: yc = 139: zc = 440: ac = 1.2: objectcopy nn, nc, xc, yc, zc, ac 'desk
nn = 1: nc = 12: xc = 80: yc = 150: zc = 470: ac = .4: objectcopy nn, nc, xc, yc, zc, ac 'desk
nn = 1: nc = 12: xc = 150: yc = -80: zc = 470: ac = .9: objectcopy nn, nc, xc, yc, zc, ac 'desk
nn = 1: nc = 12: xc = 150: yc = -80: zc = 440: ac = .9: objectcopy nn, nc, xc, yc, zc, ac 'desk
nn = 1: nc = 12: xc = 150: yc = -80: zc = 410: ac = .9: objectcopy nn, nc, xc, yc, zc, ac 'desk
'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 = 21 'resolution sphere X
db = 9 '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
boxrotate
boxmove
processtextures
processbox
'draw sky *********************************************************************************
't = 1 'use for checkered 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)
't = t * -1 'use for checkered sky
'If t > 0 Then 'use for checkered sky
_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
'End If 'use for checkered sky
Next asq
' ****************************************************************************************************
_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))
sp3 = sp(3) + (_KeyDown(Asc("d")) - _KeyDown(Asc("a"))) * 90 * pip180
vec_x = (Sin(sp3) * (Cos(sp(4) + _Pi)))
vec_y = (Cos(sp3) * (Cos(sp(4) + _Pi)))
vec_z = -Sin(sp(4) + _Pi)
If _KeyDown(Asc("a")) Or _KeyDown(Asc("d")) Then vec_z = 0
speed = 3.7 'moving speed
moving = Abs(_MouseButton(1) Or _KeyDown(Asc("w")) Or _KeyDown(Asc("a")) Or _KeyDown(Asc("d"))) * 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) < -465 Then sp(0) = -465
'If sp(1) < -465 Then sp(1) = -465
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 processtextures
Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
For t = 1 To txtot
x1 = oo(t).x1: y1 = oo(t).y1: z1 = oo(t).z1
x2 = oo(t).x2: y2 = oo(t).y2: z2 = oo(t).z2
x3 = oo(t).x3: y3 = oo(t).y3: z3 = oo(t).z3
x4 = oo(t).x4: y4 = oo(t).y4: z4 = oo(t).z4
x = oo(t).ix: y = oo(t).iy
r2m x1, y1, z1
r2m x2, y2, z2
r2m x3, y3, z3
r2m x4, y4, z4
_MapTriangle (0, 0)-(x, 0)-(0, y), tximage(oo(t).in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
_MapTriangle (x, y)-(x, 0)-(0, y), tximage(oo(t).in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
Next t
End Sub
Sub processbox
Dim s(4), z, t2, mx, my, mx1, mx2, my1, my2
Dim t, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
For t = 0 To 5
z = Val(Mid$("123425461275348617387586", t * 4 + 1, 4))
For t2 = 1 To 4
s(t2) = Val(Mid$(Str$(z), t2 + 1, 1))
Next t2
mx = t: If t > 2 Then mx = mx - 3
mx1 = mx * 150: mx2 = mx1 + 150
my = Int(t / 3)
my1 = my * 150: my2 = my1 + 150
x1 = bx(s(1), 1): y1 = bx(s(1), 2): z1 = bx(s(1), 3): r2m x1, y1, z1: x2 = bx(s(2), 1): y2 = bx(s(2), 2): z2 = bx(s(2), 3): r2m x2, y2, z2
x3 = bx(s(3), 1): y3 = bx(s(3), 2): z3 = bx(s(3), 3): r2m x3, y3, z3: x4 = bx(s(4), 1): y4 = bx(s(4), 2): z4 = bx(s(4), 3): r2m x4, y4, z4
_MapTriangle (mx1, my1)-(mx2, my1)-(mx1, my2), box1b To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
_MapTriangle (mx2, my2)-(mx2, my1)-(mx1, my2), box1b To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
Next t
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(7), BF 'wall background
For t = 1 To 6000
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(8)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(9)
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(7), BF 'wall2 background
For t = 1 To 6000
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(8)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(9)
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, y, m
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 makebox
Cls
Line (0, 0)-(450, 300), c(1), BF
Line (0, 150)-(450, 150), c(0): Line (0, 300)-(450, 300), c(0)
Line (150, 0)-(150, 300), c(0): Line (300, 0)-(300, 300), c(0)
Paint (160, 10), c(14), c(0)
Paint (310, 10), c(15), c(0)
Paint (10, 160), c(16), c(0)
Paint (160, 160), c(17), c(0)
Paint (310, 160), c(18), c(0)
'_Display
_PutImage (0, 0)-(500, 500), 0, box1, (0, 0)-(500, 500)
'Sleep
End Sub
Sub makepallette
Dim t
For t = 0 To 10
Cls
Line (0, 0)-(400, 400), c(t), BF
_PutImage (0, 0)-(400, 400), 0, cbx(t), (0, 0)-(400, 400)
'_Display
'Sleep
Next t
End Sub
Sub boxrotate
Dim t, xt, yt, xc, yc, h1, h2, h, xt2, yt2
h = 7.1 'based on cube size 20
'find XY center of cube using points 2 and 6
xc = Abs(bx(2, 1) - bx(6, 1))
If bx(6, 1) > bx(2, 1) Then
xc = bx(6, 1) - xc / 2
Else
xc = bx(2, 1) - xc / 2
End If
yc = Abs(bx(2, 2) - bx(6, 2))
If bx(6, 2) > bx(2, 2) Then
yc = bx(6, 2) - yc / 2
Else
yc = bx(2, 2) - yc / 2
End If
'XY rotation
For t = 1 To 8 'calculate rotation amount (radians) and update each point
xt = bx(t, 1)
yt = bx(t, 2)
h1 = _Atan2(xt - xc, yt - yc)
h2 = h1 - .1
xt2 = Sin(h2) * h
yt2 = Cos(h2) * h
bx(t, 1) = xc + xt2
bx(t, 2) = yc + yt2
Next t
End Sub
Sub boxmove
Dim t
If fx = 0 Then
For t = 1 To 8
bx(t, 1) = bx(t, 1) + 1
If bx(t, 1) > 140 Then
fx = 1
End If
Next t
End If
If fx = 1 Then
For t = 1 To 8
bx(t, 2) = bx(t, 2) - 4
If bx(t, 2) < -300 Then
fx = 2
End If
Next t
End If
If fx = 2 Then
For t = 1 To 8
bx(t, 1) = bx(t, 1) - 1
If bx(t, 1) < -140 Then
fx = 3
End If
Next t
End If
If fx = 3 Then
For t = 1 To 8
bx(t, 2) = bx(t, 2) + 7
If bx(t, 2) > 300 Then
fx = 0
End If
Next t
End If
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
Sub objectcopy (nn, nc, xc, yc, zc, ac)
Dim ct, t, t2, xt, yt
ct = 0
For t = 1 To 36
If raw(t).n = nc Then
ct = ct + 1
t2 = txtot + ct
oo(t2).n = nn: oo(t2).x = xc: oo(t2).y = yc: oo(t2).z = zc
xt = raw(t).x1: yt = raw(t).y1: xyrotation xt, yt, ac: oo(t2).x1 = xt + xc: oo(t2).y1 = yt + yc: oo(t2).z1 = raw(t).z1 + zc
xt = raw(t).x2: yt = raw(t).y2: xyrotation xt, yt, ac: oo(t2).x2 = xt + xc: oo(t2).y2 = yt + yc: oo(t2).z2 = raw(t).z2 + zc
xt = raw(t).x3: yt = raw(t).y3: xyrotation xt, yt, ac: oo(t2).x3 = xt + xc: oo(t2).y3 = yt + yc: oo(t2).z3 = raw(t).z3 + zc
xt = raw(t).x4: yt = raw(t).y4: xyrotation xt, yt, ac: oo(t2).x4 = xt + xc: oo(t2).y4 = yt + yc: oo(t2).z4 = raw(t).z4 + zc
oo(t2).ix = raw(t).ix: oo(t2).iy = raw(t).iy: oo(t2).in = raw(t).in
End If
Next t
txtot = txtot + ct
End Sub
Sub xyrotation (x, y, a)
Dim t, xc, yc, xt, yt, h, h1, h2, xt2, yt2
xt = x: yt = y
h = _Hypot(yt, xt)
h1 = _Atan2(xt, yt)
h2 = h1 - a
xt2 = Sin(h2) * h
yt2 = Cos(h2) * h
x = xt2
y = yt2
End Sub
Sub colour1
c(0) = _RGB(0, 0, 0)
c(1) = _RGB(255, 255, 255)
c(2) = _RGB(35, 25, 10)
c(3) = _RGB(0, 45, 85)
c(4) = _RGB(40, 50, 10)
c(5) = _RGB(0, 25, 75)
c(6) = _RGB(45, 35, 20)
c(7) = _RGB(150, 150, 150)
c(8) = _RGB(125, 125, 125)
c(9) = _RGB(100, 100, 100)
c(10) = _RGB(75, 75, 75)
c(11) = _RGB(0, 0, 0)
c(12) = _RGB(35, 25, 10)
c(13) = _RGB(0, 45, 85)
c(14) = _RGB(40, 50, 10)
c(15) = _RGB(0, 25, 75)
c(16) = _RGB(55, 25, 30)
c(17) = _RGB(175, 175, 175)
c(18) = _RGB(100, 100, 100)
c(20) = _RGB(40, 40, 10)
End Sub
Posts: 1,510
Threads: 53
Joined: Jul 2022
Reputation:
47
(12-23-2022, 08:28 PM)james2464 Wrote: Found some used office furniture for really cheap! Sort of a mess right now, but I'll organize it soon.
If this is a mess then I'd like to see when it nears completion. I'm not capable even of drawing table and chairs in two dimensions in a program other than Inkscape, and I would need those grids and guides!
Nice work. Before today I was disinterested, I have to admit, but it's exciting that more people are becoming involved in the visual foolery.
Posts: 80
Threads: 16
Joined: Apr 2022
Reputation:
25
The office building turned out very well! I like the way you use _maptriangle ! The color of the table (dark brown, light brown) is also very good!
If you want to include 3D models in the program, this is how I did it.
You can find 3d models in any format. The easiest way is to convert them to .OBJ or .3DX format. These are good because you get the position of the points and the planar contours from the points in txt. Here you have to know for yourself that it is simpler. But I think it is beneficial if, for example, you would also store the table you created in a separate file. Points are listed, and planar ridges are listed. I think you can do it easily, since you handle the points and the slopes like a professional.
Ideally, if you use .OBJ. I took out what I needed with a simple notepad.
All points begin with V. They are listed here in the file
v -129.72956895828247072 1597.69964218137511128 -0.0002602983114252076
v 0 1597.69962115040698336 -129.08742231613194917
v 129.72956895828247072 1597.69964218137511128 -0.0002602983114252076
v 0 1597.69966321234323912 129.08690171950911463
It starts with an F, as he makes skidrows out of it.
f 1918//7781 1917//7782 1921//7783 1922//7784
f 1916//7785 1915//7786 1919//7787 1920//7788
f 1915//7789 1918//7790 1922//7791 1919//7792
f 1923//7793 1926//7794 1930//7795 1927//7796
f 1920//7797 1919//7798 1923//7799 1924//7800
It should be understood that what is needed is the first term. For the first line, 1918, 1917, 1921, 1922. So, it indicates the serial number of the lines (dots) marked with "v" in the file.
There are times when you list several points in line "f". But how do we make triangles out of it? You don't have to be like that.
For example, one in the file:
f a b c d e f
then the connection of points a,b,c,d,e,f gives the hexagon.
Assigning the first two members to the others will give the entire surface divided into triangles.
for _maptriangle :
a b c
a b d
a b e
a b f
I hope I was able to formulate it clearly, and you will see that you will save a lot of time if you make a 3d model scanner based on such a system. If you understand how it works (I'm sure you do), you can easily integrate .OBJ files into the program from here.
If you like a 3D model, but you can't find it in .OBJ, there are many online 3D model converters. For example:
https://fabconvert.com/convert/3d-model
Good luck !
And Merry Christmas!!!
Posts: 80
Threads: 16
Joined: Apr 2022
Reputation:
25
I will describe it more specifically.
1.You will get an .OBJ file
2. Use a text editor to cut out everything you don't need. Only rows V and F remain.
3. Write a program that reads the file and places the points and triangles in an array
4. From here you can connect it with everything you have done so far.
I might add that you number the end of the F lines. 1,2,3. These could be texture indices. And in the program you enter: texture(1) = _loadimage.......
If this system succeeds, you can easily make a table yourself, or any other object. All you need is a piece of paper on which you draw it, and you type it yourself in a simple text editor based on the syntax.
Posts: 230
Threads: 25
Joined: Aug 2022
Reputation:
23
Thanks @MasterGy
I appreciate the information about 3d models. After reading what you posted I googled this and it seems very interesting and mostly understandable. I wonder how well these models could appear in QB64 - some of them are highly detailed. I would prefer a very simple one to try, but so far I only can find complex models, over 1mb.
Cheers and Merry Christmas!
Posts: 230
Threads: 25
Joined: Aug 2022
Reputation:
23
I tried to clean up the office and put a Christmas tree in the corner. Sorry, no time to decorate it though.
Code: (Select All) '3d globe with office - james2464 - Dec 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 scr, da, db, da2, dega, db2, degb, ss, ap, sqa
Dim sky_points, sky_image, 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
Dim sp3
Dim Shared bx(8, 3), fx
Dim t
fx = 0
Cls
colour1
Dim Shared floor1, wall1, wall2, ceiling1, ground1, sky1, box1, cbx(20)
Dim Shared branch, giftbox, giftbox2
floor1 = _NewImage(500, 500, 32): makefloor
wall1 = _NewImage(500, 100, 32): makewall
wall2 = _NewImage(500, 100, 32): makewall2
ceiling1 = _NewImage(500, 500, 32): makeceiling
ground1 = _NewImage(500, 500, 32): makeground
sky1 = _NewImage(750, 750, 32): makesky
box1 = _NewImage(500, 500, 32): makebox
branch = _NewImage(500, 100, 32): makebranch
giftbox = _NewImage(500, 100, 32)
giftbox2 = _NewImage(500, 100, 32): makegiftbox
Dim Shared box1b: box1b = _CopyImage(box1, 33)
For t = 0 To 10: cbx(t) = _NewImage(400, 400, 32): Next t: makepallette
'moving box starting position points
bx(1, 1) = -5: bx(1, 2) = -120: bx(1, 3) = 350: bx(2, 1) = -5: bx(2, 2) = -120: bx(2, 3) = 340
bx(3, 1) = 5: bx(3, 2) = -120: bx(3, 3) = 350: bx(4, 1) = 5: bx(4, 2) = -120: bx(4, 3) = 340
bx(5, 1) = -5: bx(5, 2) = -110: bx(5, 3) = 340: bx(6, 1) = 5: bx(6, 2) = -110: bx(6, 3) = 340
bx(7, 1) = -5: bx(7, 2) = -110: bx(7, 3) = 350: bx(8, 1) = 5: bx(8, 2) = -110: bx(8, 3) = 350
Dim Shared tximage(200)
For t = 0 To 10: tximage(t) = _CopyImage(cbx(t), 33): Next t
tximage(10) = _CopyImage(floor1, 33)
tximage(11) = _CopyImage(ground1, 33)
tximage(12) = _CopyImage(wall1, 33) 'office wall solid
tximage(13) = _CopyImage(wall2, 33) 'office wall with 3 windows
tximage(14) = _CopyImage(ceiling1, 33) 'office ceiling
tximage(15) = _CopyImage(branch, 33) 'tree branch
tximage(16) = _CopyImage(giftbox, 33) 'gift box
tximage(17) = _CopyImage(giftbox2, 33) 'gift box
Type mapobject
n As Integer 'object number
x As Single 'x origin
y As Single 'y origin
z As Single 'z origin
x1 As Single
y1 As Single
z1 As Single
x2 As Single
y2 As Single
z2 As Single
x3 As Single
y3 As Single
z3 As Single
x4 As Single
y4 As Single
z4 As Single
ix As Single 'image x
iy As Single 'image y
in As Integer 'image number - tximage()
End Type
Dim Shared raw(100) As mapobject, oo(900) As mapobject
'create texture point data array
Dim Shared tx(500, 19), txtot, rawtxtot
'objects and data points
Data 1,0,0,0,-250,-250,0,250,-250,0,-250,250,0,250,250,0,500,500,10: 'floor
Data 2,0,0,0,-500,-500,0,500,-500,0,-500,500,0,500,500,0,500,500,11: 'ground
Data 3,0,0,0,-250,0,50,-250,0,-50,250,0,50,250,0,-50,500,100,12: 'wall
Data 4,0,0,0,-250,0,50,-250,0,-50,250,0,50,250,0,-50,500,100,13: 'wall
Data 5,0,0,0,-250,-250,0,250,-250,0,-250,250,0,250,250,0,500,500,14: 'ceiling
Data 6,0,0,0,-250,-250,0,250,-250,0,-250,250,0,250,250,0,500,500,2: 'roof
Data 7,0,0,0,-60,1,0,60,1,0,-60,1,90,60,1,90,500,100,8: 'divider side
Data 7,0,0,0,-60,-1,0,60,-1,0,-60,-1,90,60,-1,90,500,100,8: 'side
Data 7,0,0,0,-60,1,0,-60,-1,0,60,1,0,60,-1,0,500,100,9: 'edge
Data 7,0,0,0,60,1,0,60,-1,0,60,1,90,60,-1,90,500,100,9: 'edge
Data 8,0,0,0,20,50,0,20,-50,0,-20,50,0,-20,-50,0,200,200,2: 'desk top 1
Data 8,0,0,0,20,50,2,20,-50,2,-20,50,2,-20,-50,2,200,200,2: 'top 2
Data 8,0,0,0,-20,50,2,-20,50,0,20,50,2,20,50,0,200,200,6: 'top end edge
Data 8,0,0,0,-20,-50,2,-20,-50,0,20,-50,2,20,-50,0,200,200,6: 'top end edge
Data 8,0,0,0,20,-50,2,20,50,2,20,-50,0,20,50,0,200,200,6: 'top side edge
Data 8,0,0,0,-20,-50,2,-20,50,2,-20,-50,0,-20,50,0,200,200,6: 'top side edge
Data 8,0,0,0,17,47,2,19,47,2,17,47,30,19,47,30,200,200,2: 'leg 1a
Data 8,0,0,0,17,49,2,19,49,2,17,49,30,19,49,30,200,200,2: 'leg 1b
Data 8,0,0,0,17,49,2,17,47,2,17,49,30,17,47,30,200,200,6: 'leg 1c
Data 8,0,0,0,19,49,2,19,47,2,19,49,30,19,47,30,200,200,6: 'leg 1d
Data 8,0,0,0,17,-47,2,19,-47,2,17,-47,30,19,-47,30,200,200,2: 'leg 2a
Data 8,0,0,0,17,-49,2,19,-49,2,17,-49,30,19,-49,30,200,200,2: 'leg 2b
Data 8,0,0,0,17,-49,2,17,-47,2,17,-49,30,17,-47,30,200,200,6: 'leg 2c
Data 8,0,0,0,19,-49,2,19,-47,2,19,-49,30,19,-47,30,200,200,6: 'leg 2d
Data 8,0,0,0,-19,49,2,-17,49,2,-19,49,30,-17,49,30,200,200,2: 'leg 3a
Data 8,0,0,0,-19,47,2,-17,47,2,-19,47,30,-17,47,30,200,200,2: 'leg 3b
Data 8,0,0,0,-19,47,2,-19,49,2,-19,47,30,-19,49,30,200,200,6: 'leg 3c
Data 8,0,0,0,-17,47,2,-17,49,2,-17,47,30,-17,49,30,200,200,6: 'leg 3d
Data 8,0,0,0,-19,-47,2,-17,-47,2,-19,-47,30,-17,-47,30,200,200,2: 'leg 4a
Data 8,0,0,0,-19,-49,2,-17,-49,2,-19,-49,30,-17,-49,30,200,200,2: 'leg 4b
Data 8,0,0,0,-19,-49,2,-19,-47,2,-19,-49,30,-19,-47,30,200,200,6: 'leg 4c
Data 8,0,0,0,-17,-49,2,-17,-47,2,-17,-49,30,-17,-47,30,200,200,6: 'leg 4d
Data 9,0,0,0,0,0,0,0,10,15,50,0,0,50,10,5,498,98,15: 'branch
Data 9,0,0,0,0,0,0,0,-10,15,50,0,0,50,-10,15,498,98,15: 'branch
Data 10,0,0,0,0,0,0,0,10,15,40,0,0,40,10,15,448,98,15: 'branch
Data 10,0,0,0,0,0,0,0,-10,15,40,0,0,40,-10,15,448,98,15: 'branch
Data 11,0,0,0,0,0,0,0,10,17,30,0,0,30,10,17,408,98,15: 'branch
Data 11,0,0,0,0,0,0,0,-10,17,30,0,0,30,-10,17,408,98,15: 'branch
Data 12,0,0,0,0,0,0,0,10,19,20,0,0,20,10,19,368,98,15: 'branch
Data 12,0,0,0,0,0,0,0,-10,19,20,0,0,20,-10,19,368,98,15: 'branch
Data 13,0,0,0,0,0,0,0,10,21,10,0,0,10,10,21,348,98,15: 'branch
Data 13,0,0,0,0,0,0,0,-10,21,10,0,0,10,-10,21,348,98,15: 'branch
Data 14,0,0,0,0,0,0,0,10,23,4,0,0,4,10,23,328,98,15: 'branch
Data 14,0,0,0,0,0,0,0,-10,23,4,0,0,4,-10,23,328,98,15: 'branch
Data 15,0,0,0,0,0,0,0,-10,-11,4,0,0,4,-10,-11,328,98,15: 'branch
Data 15,0,0,0,0,0,0,0,10,-11,4,0,0,4,10,-11,328,98,15: 'branch
Data 16,0,0,0,-5,5,0,-5,-5,0,5,5,0,5,-5,0,50,50,16: 'box 1 top
Data 16,0,0,0,-5,5,10,-5,-5,10,5,5,10,5,-5,10,50,50,16: 'box bottom
Data 16,0,0,0,-5,5,0,-5,5,10,5,5,0,5,5,10,50,50,16: 'box back
Data 16,0,0,0,-5,-5,0,-5,-5,10,5,-5,0,5,-5,10,50,50,16: 'box front
Data 16,0,0,0,-5,5,0,-5,5,10,-5,-5,0,-5,-5,10,50,50,16: 'box L side
Data 16,0,0,0,5,5,0,5,5,10,5,-5,0,5,-5,10,50,50,16: 'box R side
Data 17,0,0,0,-8,5,0,-8,-5,0,8,5,0,8,-5,0,200,100,16: 'box 2 top
Data 17,0,0,0,-8,5,10,-8,-5,10,8,5,10,8,-5,10,200,100,16: 'box bottom
Data 17,0,0,0,-8,5,0,-8,5,10,8,5,0,8,5,10,200,100,16: 'box back
Data 17,0,0,0,-8,-5,0,-8,-5,10,8,-5,0,8,-5,10,200,100,16: 'box front
Data 17,0,0,0,-8,5,0,-8,5,10,-8,-5,0,-8,-5,10,200,100,16: 'box L side
Data 17,0,0,0,8,5,0,8,5,10,8,-5,0,8,-5,10,200,100,16: 'box R side
Data 18,0,0,0,-5,5,0,-5,-5,0,5,5,0,5,-5,0,50,50,17: 'box 3 top
Data 18,0,0,0,-5,5,10,-5,-5,10,5,5,10,5,-5,10,50,50,17: 'box bottom
Data 18,0,0,0,-5,5,0,-5,5,10,5,5,0,5,5,10,50,50,17: 'box back
Data 18,0,0,0,-5,-5,0,-5,-5,10,5,-5,0,5,-5,10,50,50,17: 'box front
Data 18,0,0,0,-5,5,0,-5,5,10,-5,-5,0,-5,-5,10,50,50,17: 'box L side
Data 18,0,0,0,5,5,0,5,5,10,5,-5,0,5,-5,10,50,50,17: 'box R side
Data 19,0,0,0,-8,5,0,-8,-5,0,8,5,0,8,-5,0,200,100,17: 'box 4 top
Data 19,0,0,0,-8,5,10,-8,-5,10,8,5,10,8,-5,10,200,100,17: 'box bottom
Data 19,0,0,0,-8,5,0,-8,5,10,8,5,0,8,5,10,200,100,17: 'box back
Data 19,0,0,0,-8,-5,0,-8,-5,10,8,-5,0,8,-5,10,200,100,17: 'box front
Data 19,0,0,0,-8,5,0,-8,5,10,-8,-5,0,-8,-5,10,200,100,17: 'box L side
Data 19,0,0,0,8,5,0,8,5,10,8,-5,0,8,-5,10,200,100,17: 'box R side
Data 20,0,0,0,-8,5,0,-8,-5,0,8,5,0,8,-5,0,200,100,4: 'box 5 top
Data 20,0,0,0,-8,5,10,-8,-5,10,8,5,10,8,-5,10,200,100,4: 'box bottom
Data 20,0,0,0,-8,5,0,-8,5,10,8,5,0,8,5,10,200,100,3: 'box back
Data 20,0,0,0,-8,-5,0,-8,-5,10,8,-5,0,8,-5,10,200,100,3: 'box front
Data 20,0,0,0,-8,5,0,-8,5,10,-8,-5,0,-8,-5,10,200,100,5: 'box L side
Data 20,0,0,0,8,5,0,8,5,10,8,-5,0,8,-5,10,200,100,5: 'box R side
rawtxtot = 76: txtot = rawtxtot
'read data into array tx()
Dim t2
For t = 1 To txtot
For t2 = 1 To 19
Read tx(t, t2)
Next t2
'create 'raw' objects
raw(t).n = tx(t, 1): raw(t).x = tx(t, 2): raw(t).y = tx(t, 3): raw(t).z = tx(t, 4)
raw(t).x1 = tx(t, 5): raw(t).y1 = tx(t, 6): raw(t).z1 = tx(t, 7)
raw(t).x2 = tx(t, 8): raw(t).y2 = tx(t, 9): raw(t).z2 = tx(t, 10)
raw(t).x3 = tx(t, 11): raw(t).y3 = tx(t, 12): raw(t).z3 = tx(t, 13)
raw(t).x4 = tx(t, 14): raw(t).y4 = tx(t, 15): raw(t).z4 = tx(t, 16)
raw(t).ix = tx(t, 17): raw(t).iy = tx(t, 18): raw(t).in = tx(t, 19)
Next t
'object copies
Dim nn, nc, xc, yc, zc, ac
nn = 1: nc = 1: xc = 0: yc = 0: zc = 500: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'floor
nn = 1: nc = 2: xc = 0: yc = 0: zc = 502: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'ground
nn = 1: nc = 4: xc = 0: yc = -250: zc = 450: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 4: xc = 0: yc = 250: zc = 450: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 4: xc = 250: yc = 0: zc = 450: ac = _Pi / 2: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 4: xc = -250: yc = 0: zc = 450: ac = _Pi / 2: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 3: xc = 250: yc = 0: zc = 350: ac = _Pi / 2: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 3: xc = -250: yc = 0: zc = 350: ac = _Pi / 2: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 4: xc = 0: yc = -250: zc = 350: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 4: xc = 0: yc = 250: zc = 350: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 5: xc = 0: yc = 0: zc = 300: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'ceiling
nn = 1: nc = 6: xc = 0: yc = 0: zc = 299: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'roof
nn = 1: nc = 7: xc = -190: yc = -70: zc = 410: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'divider
nn = 1: nc = 8: xc = -190: yc = -40: zc = 470: ac = 1.57: objectcopy nn, nc, xc, yc, zc, ac 'desk
nn = 1: nc = 8: xc = -190: yc = -100: zc = 470: ac = 1.57: objectcopy nn, nc, xc, yc, zc, ac 'desk
nn = 1: nc = 7: xc = 190: yc = 70: zc = 410: ac = 3.14: objectcopy nn, nc, xc, yc, zc, ac 'divider
nn = 1: nc = 8: xc = 190: yc = 40: zc = 470: ac = 1.57: objectcopy nn, nc, xc, yc, zc, ac 'desk
nn = 1: nc = 8: xc = 190: yc = 100: zc = 470: ac = 1.57: objectcopy nn, nc, xc, yc, zc, ac 'desk
'nn = 1: nc = 8: xc = 0: yc = 140: zc = 470: ac = -.3: objectcopy nn, nc, xc, yc, zc, ac 'desk
'nn = 1: nc = 8: xc = 40: yc = 139: zc = 440: ac = 1.2: objectcopy nn, nc, xc, yc, zc, ac 'desk
'nn = 1: nc = 8: xc = 80: yc = 150: zc = 470: ac = .4: objectcopy nn, nc, xc, yc, zc, ac 'desk
'nn = 1: nc = 8: xc = 150: yc = -80: zc = 470: ac = .9: objectcopy nn, nc, xc, yc, zc, ac 'desk
'nn = 1: nc = 8: xc = 150: yc = -80: zc = 440: ac = .9: objectcopy nn, nc, xc, yc, zc, ac 'desk
'nn = 1: nc = 8: xc = 150: yc = -80: zc = 410: ac = .9: objectcopy nn, nc, xc, yc, zc, ac 'desk
For t = 1 To 7
nn = 1: nc = 11: xc = 180: yc = -180: zc = 490 - t / 3: ac = (6.28 / 7) * t: objectcopy nn, nc, xc, yc, zc, ac 'branch
Next t
For t = 1 To 12
nn = 1: nc = 9: xc = 180: yc = -180: zc = 480 - t / 2: ac = (6.28 / 12) * t: objectcopy nn, nc, xc, yc, zc, ac 'branch
Next t
For t = 1 To 16
nn = 1: nc = 10: xc = 180: yc = -180: zc = 470 - t: ac = (6.28 / 9) * t: objectcopy nn, nc, xc, yc, zc, ac 'branch
Next t
nn = 1: nc = 11: xc = 180: yc = -180: zc = 450: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 11: xc = 180: yc = -180: zc = 450: ac = 1.05: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 11: xc = 180: yc = -180: zc = 450: ac = 2.1: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 11: xc = 180: yc = -180: zc = 450: ac = 3.15: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 11: xc = 180: yc = -180: zc = 450: ac = 4.2: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 11: xc = 180: yc = -180: zc = 450: ac = 5.24: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 11: xc = 180: yc = -180: zc = 440: ac = .55: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 11: xc = 180: yc = -180: zc = 440: ac = 1.6: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 11: xc = 180: yc = -180: zc = 440: ac = 2.65: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 11: xc = 180: yc = -180: zc = 440: ac = 3.7: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 11: xc = 180: yc = -180: zc = 440: ac = 4.75: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 11: xc = 180: yc = -180: zc = 440: ac = 5.8: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 12: xc = 180: yc = -180: zc = 430: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 12: xc = 180: yc = -180: zc = 430: ac = 1.05: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 12: xc = 180: yc = -180: zc = 430: ac = 2.1: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 12: xc = 180: yc = -180: zc = 430: ac = 3.15: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 12: xc = 180: yc = -180: zc = 430: ac = 4.2: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 12: xc = 180: yc = -180: zc = 430: ac = 5.24: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 12: xc = 180: yc = -180: zc = 420: ac = .55: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 12: xc = 180: yc = -180: zc = 420: ac = 1.6: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 12: xc = 180: yc = -180: zc = 420: ac = 2.65: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 12: xc = 180: yc = -180: zc = 420: ac = 3.7: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 12: xc = 180: yc = -180: zc = 420: ac = 4.75: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 12: xc = 180: yc = -180: zc = 420: ac = 5.8: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 13: xc = 185: yc = -180: zc = 410: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 13: xc = 182: yc = -182: zc = 410: ac = 1.05: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 13: xc = 182: yc = -182: zc = 410: ac = 2.1: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 13: xc = 175: yc = -180: zc = 410: ac = 3.15: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 13: xc = 178: yc = -178: zc = 410: ac = 4.2: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 13: xc = 178: yc = -178: zc = 410: ac = 5.24: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 13: xc = 180: yc = -180: zc = 400: ac = .55: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 13: xc = 180: yc = -180: zc = 400: ac = 1.6: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 13: xc = 180: yc = -180: zc = 400: ac = 2.65: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 13: xc = 180: yc = -180: zc = 400: ac = 3.7: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 13: xc = 180: yc = -180: zc = 400: ac = 4.75: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 13: xc = 180: yc = -180: zc = 400: ac = 5.8: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 14: xc = 180: yc = -180: zc = 394: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 14: xc = 180: yc = -180: zc = 393: ac = 1.05: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 14: xc = 180: yc = -180: zc = 392: ac = 2.1: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 14: xc = 180: yc = -180: zc = 391: ac = 3.15: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 14: xc = 180: yc = -180: zc = 389: ac = 4.2: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 14: xc = 180: yc = -180: zc = 387: ac = 5.24: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 15: xc = 180: yc = -180: zc = 394: ac = .55: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 15: xc = 180: yc = -180: zc = 392: ac = 2.65: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 15: xc = 180: yc = -180: zc = 396: ac = 4.75: objectcopy nn, nc, xc, yc, zc, ac 'branch
nn = 1: nc = 16: xc = 150: yc = -150: zc = 489: ac = 4.75: objectcopy nn, nc, xc, yc, zc, ac 'box1
nn = 1: nc = 17: xc = 140: yc = -170: zc = 489: ac = 2.75: objectcopy nn, nc, xc, yc, zc, ac 'box2
nn = 1: nc = 18: xc = 160: yc = -140: zc = 489: ac = 3.75: objectcopy nn, nc, xc, yc, zc, ac 'box3
nn = 1: nc = 19: xc = 180: yc = -150: zc = 489: ac = 1.5: objectcopy nn, nc, xc, yc, zc, ac 'box4
nn = 1: nc = 20: xc = 150: yc = -190: zc = 489: ac = 2.2: objectcopy nn, nc, xc, yc, zc, ac 'box5
'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 = 21 'resolution sphere X
db = 9 '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
boxrotate
boxmove
processtextures
processbox
'draw sky *********************************************************************************
't = 1 'use for checkered 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)
't = t * -1 'use for checkered sky
'If t > 0 Then 'use for checkered sky
_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
'End If 'use for checkered sky
Next asq
' ****************************************************************************************************
_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))
sp3 = sp(3) + (_KeyDown(Asc("d")) - _KeyDown(Asc("a"))) * 90 * pip180
vec_x = (Sin(sp3) * (Cos(sp(4) + _Pi)))
vec_y = (Cos(sp3) * (Cos(sp(4) + _Pi)))
vec_z = -Sin(sp(4) + _Pi)
If _KeyDown(Asc("a")) Or _KeyDown(Asc("d")) Then vec_z = 0
speed = 2.7 'moving speed
moving = Abs(_MouseButton(1) Or _KeyDown(Asc("w")) Or _KeyDown(Asc("a")) Or _KeyDown(Asc("d"))) * 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) < -465 Then sp(0) = -465
'If sp(1) < -465 Then sp(1) = -465
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 processtextures
Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
For t = 1 To txtot
x1 = oo(t).x1: y1 = oo(t).y1: z1 = oo(t).z1
x2 = oo(t).x2: y2 = oo(t).y2: z2 = oo(t).z2
x3 = oo(t).x3: y3 = oo(t).y3: z3 = oo(t).z3
x4 = oo(t).x4: y4 = oo(t).y4: z4 = oo(t).z4
x = oo(t).ix: y = oo(t).iy
r2m x1, y1, z1
r2m x2, y2, z2
r2m x3, y3, z3
r2m x4, y4, z4
_MapTriangle (0, 0)-(0, y)-(x, 0), tximage(oo(t).in) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
_MapTriangle (x, y)-(0, y)-(x, 0), tximage(oo(t).in) To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
Next t
End Sub
Sub processbox
Dim s(4), z, t2, mx, my, mx1, mx2, my1, my2
Dim t, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
For t = 0 To 5
z = Val(Mid$("123425461275348617387586", t * 4 + 1, 4))
For t2 = 1 To 4
s(t2) = Val(Mid$(Str$(z), t2 + 1, 1))
Next t2
mx = t: If t > 2 Then mx = mx - 3
mx1 = mx * 150: mx2 = mx1 + 150
my = Int(t / 3)
my1 = my * 150: my2 = my1 + 150
x1 = bx(s(1), 1): y1 = bx(s(1), 2): z1 = bx(s(1), 3): r2m x1, y1, z1: x2 = bx(s(2), 1): y2 = bx(s(2), 2): z2 = bx(s(2), 3): r2m x2, y2, z2
x3 = bx(s(3), 1): y3 = bx(s(3), 2): z3 = bx(s(3), 3): r2m x3, y3, z3: x4 = bx(s(4), 1): y4 = bx(s(4), 2): z4 = bx(s(4), 3): r2m x4, y4, z4
_MapTriangle (mx1, my1)-(mx2, my1)-(mx1, my2), box1b To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
_MapTriangle (mx2, my2)-(mx2, my1)-(mx1, my2), box1b To(x4, y4, z4)-(x2, y2, z2)-(x3, y3, z3), , _Smooth
Next t
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(7), BF 'wall background
For t = 1 To 6000
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(8)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(9)
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(7), BF 'wall2 background
For t = 1 To 6000
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(8)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 100): PSet (x1, y1), c(9)
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 makebranch
Dim t, x1, y1, t2
Cls
Line (0, 0)-(500, 98), c(20), BF
For t = 1 To 6000
x1 = Int(Rnd * 500): y1 = Int(Rnd * 98): PSet (x1, y1), c(0)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 98): PSet (x1, y1), c(2)
x1 = Int(Rnd * 500): y1 = Int(Rnd * 98): PSet (x1, y1), c(6)
Next t
t = 0
t2 = 15
Do
Line (t, t2)-(t, 102), c(0)
Select Case t
Case Is < 70
t2 = t2 + 1.2
Case 71 To 130
t2 = t2 - 1.2
Case 131 To 170
t2 = t2 + 1.1
Case 171 To 210
t2 = t2 - 1.2
Case 211 To 250
t2 = t2 + 1.1
Case 251 To 280
t2 = t2 - 1.3
Case 281 To 310
t2 = t2 + 1.2
Case 311 To 340
t2 = t2 - 1.3
Case 341 To 370
t2 = t2 + 1.2
Case 371 To 400
t2 = t2 - 1.4
Case 401 To 430
t2 = t2 + 1.2
Case 431 To 460
t2 = t2 - 1.4
Case 461 To 480
t2 = t2 + 1.2
Case 481 To 501
t2 = t2 - 1.5
End Select
t = t + 1
Loop Until t > 500
'_Display
_PutImage (0, 0)-(500, 100), 0, branch, (0, 0)-(500, 100)
_ClearColor c(0), branch
'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, y, m
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 makebox
Cls
Line (0, 0)-(450, 300), c(1), BF
Line (0, 150)-(450, 150), c(0): Line (0, 300)-(450, 300), c(0)
Line (150, 0)-(150, 300), c(0): Line (300, 0)-(300, 300), c(0)
Paint (160, 10), c(14), c(0)
Paint (310, 10), c(15), c(0)
Paint (10, 160), c(16), c(0)
Paint (160, 160), c(17), c(0)
Paint (310, 160), c(18), c(0)
'_Display
_PutImage (0, 0)-(500, 500), 0, box1, (0, 0)-(500, 500)
'Sleep
End Sub
Sub makegiftbox
Dim t, ct, t1, t2, t3, t4, t5
Cls
Line (0, 0)-(500, 500), c(1), BF
For t = 0 To 700
c(99) = c(t Mod 30 + 1)
Line (t - 100, 0)-(t, 100), c(99)
c(99) = c(t * .1 Mod 5 + 3)
Line (t - 50, 100)-(t, 200), c(99)
c(99) = c(t / 100 + 3)
Line (t - 90, 200)-(t, 300), c(99)
c(99) = c(t / 100 + 4)
Line (t - 90, 300)-(t, 400), c(99)
c(99) = c(t / 100 + 5)
Line (t - 90, 400)-(t, 500), c(99)
Next t
'_Display
_PutImage (0, 0)-(500, 100), 0, giftbox, (0, 0)-(500, 100)
_PutImage (0, 0)-(500, 100), 0, giftbox2, (0, 100)-(500, 200)
'Sleep
End Sub
Sub makepallette
Dim t
For t = 0 To 10
Cls
Line (0, 0)-(400, 400), c(t), BF
_PutImage (0, 0)-(400, 400), 0, cbx(t), (0, 0)-(400, 400)
'_Display
'Sleep
Next t
End Sub
Sub boxrotate
Dim t, xt, yt, xc, yc, h1, h2, h, xt2, yt2
h = 7.1 'based on cube size 20
'find XY center of cube using points 2 and 6
xc = Abs(bx(2, 1) - bx(6, 1))
If bx(6, 1) > bx(2, 1) Then
xc = bx(6, 1) - xc / 2
Else
xc = bx(2, 1) - xc / 2
End If
yc = Abs(bx(2, 2) - bx(6, 2))
If bx(6, 2) > bx(2, 2) Then
yc = bx(6, 2) - yc / 2
Else
yc = bx(2, 2) - yc / 2
End If
'XY rotation
For t = 1 To 8 'calculate rotation amount (radians) and update each point
xt = bx(t, 1)
yt = bx(t, 2)
h1 = _Atan2(xt - xc, yt - yc)
h2 = h1 - .1
xt2 = Sin(h2) * h
yt2 = Cos(h2) * h
bx(t, 1) = xc + xt2
bx(t, 2) = yc + yt2
Next t
End Sub
Sub boxmove
Dim t
If fx = 0 Then
For t = 1 To 8
bx(t, 1) = bx(t, 1) + 1
If bx(t, 1) > 140 Then
fx = 1
End If
Next t
End If
If fx = 1 Then
For t = 1 To 8
bx(t, 2) = bx(t, 2) - 4
If bx(t, 2) < -300 Then
fx = 2
End If
Next t
End If
If fx = 2 Then
For t = 1 To 8
bx(t, 1) = bx(t, 1) - 1
If bx(t, 1) < -140 Then
fx = 3
End If
Next t
End If
If fx = 3 Then
For t = 1 To 8
bx(t, 2) = bx(t, 2) + 7
If bx(t, 2) > 300 Then
fx = 0
End If
Next t
End If
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
Sub objectcopy (nn, nc, xc, yc, zc, ac)
Dim ct, t, t2, xt, yt
ct = 0
For t = 1 To rawtxtot
If raw(t).n = nc Then
ct = ct + 1
t2 = txtot + ct
oo(t2).n = nn: oo(t2).x = xc: oo(t2).y = yc: oo(t2).z = zc
xt = raw(t).x1: yt = raw(t).y1: xyrotation xt, yt, ac: oo(t2).x1 = xt + xc: oo(t2).y1 = yt + yc: oo(t2).z1 = raw(t).z1 + zc
xt = raw(t).x2: yt = raw(t).y2: xyrotation xt, yt, ac: oo(t2).x2 = xt + xc: oo(t2).y2 = yt + yc: oo(t2).z2 = raw(t).z2 + zc
xt = raw(t).x3: yt = raw(t).y3: xyrotation xt, yt, ac: oo(t2).x3 = xt + xc: oo(t2).y3 = yt + yc: oo(t2).z3 = raw(t).z3 + zc
xt = raw(t).x4: yt = raw(t).y4: xyrotation xt, yt, ac: oo(t2).x4 = xt + xc: oo(t2).y4 = yt + yc: oo(t2).z4 = raw(t).z4 + zc
oo(t2).ix = raw(t).ix: oo(t2).iy = raw(t).iy: oo(t2).in = raw(t).in
End If
Next t
txtot = txtot + ct
End Sub
Sub xyrotation (x, y, a)
Dim xt, yt, h, h1, h2, xt2, yt2
xt = x: yt = y
h = _Hypot(yt, xt)
h1 = _Atan2(xt, yt)
h2 = h1 - a
xt2 = Sin(h2) * h
yt2 = Cos(h2) * h
x = xt2
y = yt2
End Sub
Sub colour1
c(0) = _RGB(0, 0, 0)
c(1) = _RGB(255, 255, 255)
c(2) = _RGB(35, 25, 10)
c(3) = _RGB(0, 45, 85)
c(4) = _RGB(40, 50, 10)
c(5) = _RGB(0, 25, 75)
c(6) = _RGB(45, 35, 20)
c(7) = _RGB(150, 150, 150)
c(8) = _RGB(125, 125, 125)
c(9) = _RGB(100, 100, 100)
c(10) = _RGB(75, 75, 75)
c(11) = _RGB(0, 0, 0)
c(12) = _RGB(35, 25, 10)
c(13) = _RGB(0, 45, 85)
c(14) = _RGB(40, 50, 10)
c(15) = _RGB(0, 25, 75)
c(16) = _RGB(55, 25, 30)
c(17) = _RGB(175, 175, 175)
c(18) = _RGB(100, 100, 100)
c(20) = _RGB(40, 40, 10)
End Sub
Posts: 2,700
Threads: 124
Joined: Apr 2022
Reputation:
134
12-24-2022, 06:34 PM
(This post was last modified: 12-24-2022, 06:37 PM by bplus.)
Progressing well, very nice wrapping!
The tree needs more lights. 
b = b + ...
Posts: 80
Threads: 16
Joined: Apr 2022
Reputation:
25
wow! I really like the Christmas tree and the presents under it! Creative ! And you solved it quickly! Keep it up !
Small 3d model files are worth looking for. google search "low poly" , "free low poly".
For example:
https://free3d.com/3d-model/low-poly-tree-449895.html
Posts: 230
Threads: 25
Joined: Aug 2022
Reputation:
23
(12-24-2022, 07:20 PM)MasterGy Wrote: wow! I really like the Christmas tree and the presents under it! Creative ! And you solved it quickly! Keep it up !
Small 3d model files are worth looking for. google search "low poly" , "free low poly".
For example:
https://free3d.com/3d-model/low-poly-tree-449895.html
Thanks, I found one there (.obj), which I opened in Notepad and it looks like this:
v -321.4860 248.4415 -330.6384
v -321.4583 248.1794 -331.9023
v -319.3314 248.1841 -331.8872
v -319.3587 248.4463 -330.6231
v -321.5152 248.7196 -329.3937
v -319.3874 248.7244 -329.3781
v -323.6223 248.7138 -329.4130
v -323.5925 248.4357 -330.6576
v -323.5643 248.1737 -331.9213
v -321.5462 249.0136 -328.1689
v -319.4179 249.0185 -328.1530
v -321.5789 249.3238 -326.9648
v -319.4501 249.3287 -326.9485
v -323.6871 249.3179 -326.9843
v -323.6539 249.0078 -328.1883
v -325.7407 249.0019 -328.2078
v -325.7085 248.7079 -329.4325
v -325.7744 249.3120 -327.0038
v -327.8407 249.3056 -327.0243
v -327.8063 248.9957 -328.2281
v -327.7737 248.7017 -329.4527
v -325.6783 248.4298 -330.6771
v -325.6495 248.1678 -331.9408
etc etc
I'll give this a try soon! Should be fun to import these.
Posts: 230
Threads: 25
Joined: Aug 2022
Reputation:
23
(12-24-2022, 06:34 PM)bplus Wrote: Progressing well, very nice wrapping!
The tree needs more lights.
Thanks! Yes more lights and ornaments needed! 
|
