12-26-2022, 05:19 PM (This post was last modified: 12-26-2022, 06:15 PM by james2464.
Edit Reason: Cool effect on the model
)
Got my first model import working. Not the textures, just the shape.
The data is in the attached text file. It will load this file and then create a new file "convert.txt". Then it reads that into the program. I'm not sure this is the best way to do this but that's what I came up with for now.
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
Open "cat-v.txt" For Input As #1 ' open for sequential read
Open "convert.txt" For Output As #2
Dim count, ct, a$, b$, ch1$, ch2$, ch3$, ch4$, p1, flag, space(4)
While Not EOF(1)
ch1$ = ""
Line Input #1, a$
ct = ct + 1
For t = 1 To Len(a$)
b$ = Mid$(a$, t, 1)
If b$ = " " Then
p1 = Len(a$) - t
If p1 > 1 Then
ch1$ = ch1$ + ","
End If
Else
ch1$ = ch1$ + b$
End If
Next t
Print #2, ch1$
Wend
Close #2
Close #1
_Delay 1
Open "convert.txt" For Input As #1 ' open for sequential read
Dim Shared cval(5000), tv$(5000), xval(5000), yval(5000), zval(5000), maxv
Cls
ct = 0
p1 = 1
Do
ct = ct + 1
Input #1, tv$(ct), xval(ct), yval(ct), zval(ct)
cval(ct) = ct
p1 = EOF(1)
If p1 < 0 Then
flag = 1
End If
Loop Until flag = 1
Close #1
maxv = ct
_Delay 1
colour1
Dim Shared floor1, wall1, wall2, ceiling1, ground1, sky1, box1, cbx(20)
Dim Shared branch, giftbox, giftbox2
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
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
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
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
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
the cat turned out very well! I look forward to further developments!
I haven't tried it yet, but in principle texturing works in such a way that the second member in the "f" lines is "xxxx // yyyy", so yyyy specifies the location of the point in the texture image. If you load an arbitrary image in its place, you can set how much of the image to zoom by multiplying yyyy. I don't know if it's understandable. So far, I've only used texturing by writing a separate program to see the model, and I can specify which image to assign to each of the triangles. But if you want to display the model completely realistically, you should try to use the original textura-font defining values, i.e. the second members in rows F. Good luck !
SMCneil !Don't be upset that I'm only now answering! I'm also in a lot of development, and I do that when I have time. Maybe I'm getting it right. Not sure. The idea sounds interesting. After the holidays, and when I'm done developing my new program, I'll try to make a program you came up with.
(12-27-2022, 10:46 AM)MasterGy Wrote: the cat turned out very well! I look forward to further developments!
I haven't tried it yet, but in principle texturing works in such a way that the second member in the "f" lines is "xxxx // yyyy", so yyyy specifies the location of the point in the texture image. If you load an arbitrary image in its place, you can set how much of the image to zoom by multiplying yyyy. I don't know if it's understandable. So far, I've only used texturing by writing a separate program to see the model, and I can specify which image to assign to each of the triangles. But if you want to display the model completely realistically, you should try to use the original textura-font defining values, i.e. the second members in rows F. Good luck !
Thank you for explaining, I'll try this. Should be interesting to see the full 3d model in QB64, complete with texturing.
This has led to a different idea. Until this 3d model test, I thought _maptriangle was only used for square images. Break the square into two triangles and then put back together into a square, after some transformation. But this 3d model test was only using triangles. So only 1 _maptriangle was necessary.
Anyway I wondered about making a terrain map, using random numbers. If I could just take a square texture image and split it up into triangles, then modify the z points up or down. And to my surprise, it works! I then added water to make it easier to view.
Code: (Select All)
'3d terrain and water - 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 t
Dim Shared trx(2000), try(2000), trz(2000) 'terrain points
Dim Shared fr1(2000), fr2(2000), fr3(2000) 'terrain point groups
Dim Shared maxterrain
Cls
colour1
Dim Shared floor1, wall1, wall2, ground1, sky1, cbx(20)
For t = 0 To 10: cbx(t) = _NewImage(400, 400, 32): Next t: makepallette
Dim Shared tximage(200)
For t = 0 To 10: tximage(t) = _CopyImage(cbx(t), 33): Next t
tximage(11) = _CopyImage(ground1, 33)
tximage(12) = _CopyImage(wall1, 33) 'office wall solid
tximage(13) = _CopyImage(wall2, 33) 'office wall with 3 windows
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,-1000,0,200,-1000,0,-200,1000,0,200,1000,0,-200,500,100,12: 'wall
Data 2,0,0,0,-2000,-2000,0,-2000,2000,0,2000,-2000,0,2000,2000,0,500,100,3: 'water
rawtxtot = 2: 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 = 400: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'wall
nn = 1: nc = 2: xc = 0: yc = 0: zc = 510: ac = 0: objectcopy nn, nc, xc, yc, zc, ac 'water
'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
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
Sub processterrain
Dim t, x, y, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4
Dim flag, ct, scale1, shx, shy, shz, txm
flag = 0
ct = 0
scale1 = 7
shx = -1500 'shift x position
shy = -1500 'shift y position
shz = 500 'shift z position
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 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 maketerrain
Dim t, s, x, y, x1, y1, p, q, p2, ct, ct2, flag
Cls
'Line (0, 0)-(500, 500), c(20), BF 'background
t = 0
x1 = 500: y1 = 500
s = 20
'create points (trx,try,trz)
For x = 0 To x1 Step s
For y = 0 To y1 Step s
t = t + 1
trx(t) = x - s: try(t) = y - s: trz(t) = Rnd * 150 - 75
'c(99) = _RGB32(255 - trz(t) * 50, 255 - trz(t) * 50, 255 - trz(t) * 50)
'Line (x - 5, y - 5)-(x + 5, y + 5), c(99), BF
Next y
Next x
'_Display
'Sleep
'create point groups (fr1,fr2,fr3)
p = Int(x1 / s) + 1
q = Int(y1 / s) - 1
p2 = p * q
t = -1
flag = 0
ct = 0
x = 0
Do
For x = 1 To p - 1
t = t + 2
fr1(t) = x + ct
fr2(t) = x + ct + 1
fr3(t) = x + ct + p
fr1(t + 1) = x + ct + 1
fr2(t + 1) = x + ct + p
fr3(t + 1) = x + ct + p + 1
Next x
ct = ct + p
If ct > p2 Then flag = 1
Loop Until flag = 1
maxterrain = t + 1
'Cls
't = t + 1
'For ct = 1 To t
'Print fr1(ct), fr2(ct), fr3(ct)
'Next ct
'Cls
'For t = 1 To maxterrain
'Line (trx(fr1(t)), try(fr1(t)))-(trx(fr2(t)), try(fr2(t))), c(1)
'Line (trx(fr2(t)), try(fr2(t)))-(trx(fr3(t)), try(fr3(t))), c(1)
'Line (trx(fr3(t)), try(fr3(t)))-(trx(fr1(t)), try(fr1(t))), c(1)
'Next t
'_Display
'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 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