3d surface images

[OldMoses]

I am in awe. Amazing stuff there. Well done.

[james2464]

I am in awe. Amazing stuff there. Well done.

Thanks, this is really interesting what can be done with QB64.  Cheers!

[james2464]

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

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
    drawmodel

    '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 drawmodel
    'draw imported model
    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 = .07
    shx = 80
    shy = -170
    shz = 500

    Do
        ct = ct + 1
        If tv$(ct) = "f" Then
            x1 = xval(xval(ct)) * scale1 + shx: y1 = zval(xval(ct)) * scale1 + shy: z1 = -yval(xval(ct)) * scale1 + shz
            x2 = xval(yval(ct)) * scale1 + shx: y2 = zval(yval(ct)) * scale1 + shy: z2 = -yval(yval(ct)) * scale1 + shz
            x3 = xval(zval(ct)) * scale1 + shx: y3 = zval(zval(ct)) * scale1 + shy: z3 = -yval(zval(ct)) * scale1 + shz


            x = 50: y = 50 'from texture image
            r2m x1, y1, z1
            r2m x2, y2, z2
            r2m x3, y3, z3
            txm = int(rnd*9)
            _MapTriangle (0, 0)-(0, y)-(x, 0), tximage(txm) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth

        End If
        If ct >= maxv Then flag = 1
    Loop Until flag = 1

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

[MasterGy]

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 !

[MasterGy]

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.

[james2464]

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)



wall1 = _NewImage(500, 100, 32): makewall
wall2 = _NewImage(500, 100, 32): makewall2
ground1 = _NewImage(500, 500, 32): makeground
sky1 = _NewImage(750, 750, 32): makesky

maketerrain

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

'create screen
scr = _NewImage(1000, 1000 / _DesktopWidth * _DesktopHeight, 32)
Screen scr
_MouseHide
_FullScreen
_Dest scr
_DisplayOrder _Hardware , _Software


'sky install
da = 11 'resolution sphere X
db = 7 '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 = 4500
        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

    processterrain
    processtextures



    '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 = 5.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 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 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

    Do
        ct = ct + 1

        x1 = trx(fr1(ct)) * scale1 + shx: y1 = try(fr1(ct)) * scale1 + shy: z1 = trz(fr1(ct)) + shz
        x2 = trx(fr2(ct)) * scale1 + shx: y2 = try(fr2(ct)) * scale1 + shy: z2 = trz(fr2(ct)) + shz
        x3 = trx(fr3(ct)) * scale1 + shx: y3 = try(fr3(ct)) * scale1 + shy: z3 = trz(fr3(ct)) + shz

        'x1 = trx(fr1(ct)): y1 = try(fr1(ct)): z1 = trz(fr1(ct))
        'x2 = trx(fr2(ct)): y2 = try(fr2(ct)): z2 = trz(fr2(ct))
        'x2 = trx(fr3(ct)): y3 = try(fr3(ct)): z3 = trz(fr3(ct))



        x = 150: y = 150 'from texture image
        r2m x1, y1, z1
        r2m x2, y2, z2
        r2m x3, y3, z3
        txm = 11
        _MapTriangle (0, 0)-(0, y)-(x, 0), tximage(txm) To(x1, y1, z1)-(x2, y2, z2)-(x3, y3, z3), , _Smooth

        If ct >= maxterrain Then flag = 1
    Loop Until flag = 1

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 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 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(6)
        x1 = Int(Rnd * 500): y1 = Int(Rnd * 500): PSet (x1, y1), c(4)
        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(6)
    Next t
    '_Display
    _PutImage (0, 0)-(500, 500), 0, ground1, (0, 0)-(500, 500)
    '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



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