×
INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
• Talk With Other Members
• Be Notified Of Responses
• Keyword Search
Favorite Forums
• Automated Signatures
• Best Of All, It's Free!

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

#### Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

(OP)

Allright, here's the full code.

X + Y rotations seem so almost work, although they just seem to shrink and stretch (instead of a real rotation), and most angles on X or Y rotations make the wireframe look too small :(

It's something to do with the perspective, I believe, but I cannot figure it out.. calling all QB coders or trig experts or BASIC 3d programmers to please give a hand =)

A Z-axis rotation works fine...

I put comments throughout the code explaining stuff.
Sorry if my code is hard to understand =(

DECLARE SUB Draw3D (WF() AS ANY, R!, XR!, YR!)
DECLARE SUB Draw3DE (WF() AS ANY, R!, XR!, YR!)
'Perspective Functions
DECLARE FUNCTION X2D (X, Z) 'Convert X,Z to X (used only by Draw3D + Draw3DE)
DECLARE FUNCTION Y2D (Y, Z) 'Convert Y,Z to Y (used only by Draw3D + Draw3DE)

'Drawing Subroutines
DECLARE SUB Draw3D (WF() AS ANY, R, XR, YR) 'Draws a wireframe
'Uses functions to rotate each point in the Wireframe

DECLARE SUB Draw3DE (WF() AS ANY, R, XR, YR) 'Erases wireframe, shows stats
'Uses functions to rotate each point in the Wireframe

'Performs rotations by reference of variables
DECLARE SUB RX (Y, Z, R) 'Rotates about X axis (not working), used by Draw3D
DECLARE SUB RZ (Y, X, R) 'Rotates about Y axis (not working), used by Draw3D
DECLARE SUB RY (X, Z, R) 'Rotates about Z axis (working), used by Draw3D

TYPE Wireframe
X AS INTEGER '3D X Coordinant
Y AS INTEGER '3D Y Coordinant
Z AS INTEGER '3D Z Coordinant

'A,B,C can be used to link to points(another subscript in the
'array)

A AS INTEGER
B AS INTEGER
C AS INTEGER
END TYPE

SCREEN 12
CLS
PRINT "Which rotation to perform? (X/Y/Z)";

DO
K$= UCASE$(INKEY$) LOOP UNTIL K$ = "X" OR K$= "Y" OR K$ = "Z"

'Sets the option to 1, because the angle is multiplied by 1 or 0 to tell
'Draw3D the rotation.

IF K$= "X" THEN XXR = 1 IF K$ = "Y" THEN YYR = 1
IF K$= "Z" THEN ZZR = 1 DIM SHARED HSRX, HSRY HSRX = 320 HSRY = 240 'Used for perceptective... I don't think this would cause the rotation 'problem. DIM Cube(8) AS Wireframe 'This is our wireframe Cube(1).X = 100 Cube(1).Y = 100 Cube(1).Z = 1 Cube(1).A = 2 Cube(1).B = 5 Cube(2).X = 200 Cube(2).Y = 100 Cube(2).Z = 1 Cube(2).A = 4 Cube(2).B = 6 Cube(3).X = 100 Cube(3).Y = 200 Cube(3).Z = 1 Cube(3).A = 1 Cube(3).B = 7 Cube(4).X = 200 Cube(4).Y = 200 Cube(4).Z = 1 Cube(4).A = 3 Cube(4).B = 8 Cube(5).X = 150 Cube(5).Y = 150 Cube(5).Z = 2 Cube(5).A = 6 Cube(6).X = 250 Cube(6).Y = 150 Cube(6).Z = 2 Cube(6).A = 8 Cube(7).X = 150 Cube(7).Y = 250 Cube(7).Z = 2 Cube(7).A = 5 Cube(7).B = 8 Cube(8).X = 250 Cube(8).Y = 250 Cube(8).Z = 2 Cube(8).A = 8 'Call Drawing subs and rotate from 1* to 360* FOR X = 1 TO 360 STEP 1 Draw3D Cube(), ZZR * X, XXR * X, YYR * X IF X < 360 THEN Draw3DE Cube(), ZZR * X, XXR * X, YYR * X NEXT X SUB Draw3D (WF() AS Wireframe, R, XR, YR) FOR PNT = 1 TO 8 XX = WF(PNT).X YY = WF(PNT).Y ZZ = WF(PNT).Z 'Get points into 3 variables 'Check for rotation parameters 'and rotate points IF R > 0 THEN CALL RZ(YY, XX, R) IF XR > 0 THEN CALL RX(YY, ZZ, XR) IF YR > 0 THEN CALL RY(XX, ZZ, YR) 'Get the X and Y from x,y,z X = X2D(XX, ZZ) Y = Y2D(YY, ZZ) 'Place a color-coded circle on the point CIRCLE (X, Y), 3, PNT 'Check for links, rotate them if needed, get X & Y, then draw a line. IF WF(PNT).A > 0 THEN A = WF(PNT).A AX = WF(A).X AY = WF(A).Y AZ = WF(A).Z IF R > 0 THEN CALL RZ(AY, AX, R) IF XR > 0 THEN CALL RX(AY, AZ, XR) IF YR > 0 THEN CALL RY(AX, AZ, YR) xa = X2D(AX, AZ) ya = Y2D(AY, AZ) LINE (X, Y)-(xa, ya), 4 END IF IF WF(PNT).B > 0 THEN A = WF(PNT).B AX = WF(A).X AY = WF(A).Y AZ = WF(A).Z IF R > 0 THEN CALL RZ(AY, AX, R) IF XR > 0 THEN CALL RX(AY, AZ, XR) IF YR > 0 THEN CALL RY(AX, AZ, YR) xa = X2D(AX, AZ) ya = Y2D(AY, AZ) LINE (X, Y)-(xa, ya), 4 END IF IF WF(PNT).C > 0 THEN A = WF(PNT).C AX = WF(A).X AY = WF(A).Y AZ = WF(A).Z IF R > 0 THEN CALL RZ(AY, AX, R) IF XR > 0 THEN CALL RX(AY, AZ, XR) IF YR > 0 THEN CALL RY(AX, AZ, YR) xa = X2D(AX, AZ) ya = Y2D(AY, AZ) LINE (X, Y)-(xa, ya), 4 END IF NEXT END SUB SUB Draw3DE (WF() AS Wireframe, R, XR, YR) LOCATE 1, 1 COLOR 15 PRINT "Z Rotation:"; R; "X Rotation:"; XR; "Y Rotation:"; YR FOR PNT = 1 TO 8 XX = WF(PNT).X YY = WF(PNT).Y ZZ = WF(PNT).Z IF R > 0 THEN CALL RZ(YY, XX, R) IF XR > 0 THEN CALL RX(YY, ZZ, XR) IF YR > 0 THEN CALL RY(XX, ZZ, YR) COLOR PNT PRINT "("; LTRIM$(RTRIM$(STR$(PNT))); ")X:"; XX; "Y:"; YY; "Z:"; ZZ;

X = X2D(XX, ZZ)
Y = Y2D(YY, ZZ)

PRINT "NX:"; X; "NY:"; Y

CIRCLE (X, Y), 3, 0
IF WF(PNT).A > 0 THEN
A = WF(PNT).A
AX = WF(A).X
AY = WF(A).Y
AZ = WF(A).Z
IF R > 0 THEN CALL RZ(AY, AX, R)
IF XR > 0 THEN CALL RX(AY, AZ, XR)
IF YR > 0 THEN CALL RY(AX, AZ, YR)

xa = X2D(AX, AZ)
ya = Y2D(AY, AZ)
LINE (X, Y)-(xa, ya), 0
END IF
IF WF(PNT).B > 0 THEN
A = WF(PNT).B
AX = WF(A).X
AY = WF(A).Y
AZ = WF(A).Z
IF R > 0 THEN CALL RZ(AY, AX, R)
IF XR > 0 THEN CALL RX(AY, AZ, XR)
IF YR > 0 THEN CALL RY(AX, AZ, YR)

xa = X2D(AX, AZ)
ya = Y2D(AY, AZ)
LINE (X, Y)-(xa, ya), 0
END IF
IF WF(PNT).C > 0 THEN
A = WF(PNT).C
AX = WF(A).X
AY = WF(A).Y
AZ = WF(A).Z
IF R > 0 THEN CALL RZ(AY, AX, R)
IF XR > 0 THEN CALL RX(AY, AZ, XR)
IF YR > 0 THEN CALL RY(AX, AZ, YR)

xa = X2D(AX, AZ)
ya = Y2D(AY, AZ)
LINE (X, Y)-(xa, ya), 0
END IF
NEXT

END SUB

SUB RX (Y, Z, R)
YY = (Y * COS(Rad)) - (Z * SIN(Rad)) 'Performs y rotation
ZZ = (Y * SIN(Rad)) - (Z * COS(Rad)) 'Performs z rotation
Y = YY 'changes Y,Z
Z = ZZ
END SUB

SUB RY (X, Z, R)
Rad = R * (3.14 / 180)
X = XX
Z = ZZ

END SUB

SUB RZ (Y, X, R)
Rad = R * (3.14 / 180)
X = XX
Y = YY
END SUB

FUNCTION X2D (X, Z)
X2D = X / Z + HSRX
END FUNCTION

FUNCTION Y2D (Y, Z)
Y2D = Y / Z + HSRY
END FUNCTION

I took that program; tried to fix problem posted. Notice: actually all 3 rotation should be similar (if not the same). But I think it's perspective that breaks that.
People here said "It's smth in a math" but no one got interested enough to look closer.
Anyway, I did'n quite get what projection you used... so I took your program, your data structures and fiddled with it for a week (or more?)
Anyway, here's what I got.

DECLARE FUNCTION ask! (b$) DECLARE FUNCTION iif$ (cond!, yes$, no$)
DECLARE SUB ClearDraw (WF() AS ANY)
DECLARE SUB fillCube (WF() AS ANY)
'Performs rotations by reference of variables
DECLARE SUB Rot (y!, x!, R!)
DECLARE SUB Draw3D (WF() AS ANY, ZR!, XR!, YR!)
'3d->2d conversion
DECLARE FUNCTION X2D (x, y, z)
DECLARE FUNCTION Y2D (x, y, z)

TYPE Wireframe
x AS INTEGER '3D X Coordinant
y AS INTEGER '3D Y Coordinant
z AS INTEGER '3D Z Coordinant

'A,B,C can be used to link to points(another subscript in the
'array)

a AS INTEGER
b AS INTEGER
c AS INTEGER
END TYPE

'boolean consts
COMMON SHARED True, False

'some consts
sqr3half = SQR(3) / 2
sqr2half = SQR(2) / 2
False = 0: True = NOT False

'boolean controls
DIM SHARED usePerspective, isDimetry, isIzometry
'by def, isDimetry = NOT isIzometry

'internals, speed up: calculated 2d (screen) pts
DIM X2(8), Y2(8)

DIM Cube(8) AS Wireframe

fillCube Cube()

SCREEN 12
'let Basic do as much scaling as it could... Well, it could be slower

'--- Show all variety ---

FOR i = -1 TO 0   'for isIzometry
x = 430 + 210 * i
FOR p = -1 TO 0   'for projection
y = 220 + 210 * p
colr = 1 + (i + 1) + 2 * (p + 1)
VIEW (x, y)-(x + 200, y + 200), , colr
WINDOW (-200, -200)-(200, 200)
isIzometry = i
isDimetry = NOT isIzometry
COLOR colr
PRINT "Projection used: ";
PRINT iif$(isDimetry, "Dimetry", "Izometry") usePerspective = p PRINT "Perspective used: "; PRINT iif$(usePerspective, "Yes", "No")

Draw3D Cube(), 0, 0, 0

NEXT
NEXT

a$= INPUT$(1) 'pause till key pressed

'--- Now let user choose, then show rotation ---

COLOR 7
CLS 0
VIEW (230, 10)-(630, 410), , 1
WINDOW (-200, -200)-(200, 200)

usePerspective = False
PRINT "Press a key for Projection: "
PRINT "Izometry (ENTER) or Dimetry"
isIzometry = ask(CHR$(13)) isDimetry = NOT isIzometry PRINT "Projection selected: "; PRINT iif$(isDimetry, "Dimetry", "Izometry")

PRINT "Press a key for Perspective: "
PRINT "Use (ENTER) or Do Not Use"
usePerspective = ask(CHR$(13)) PRINT "Perspective selected: "; PRINT iif$(usePerspective, "Yes", "No")

Draw3D Cube(), 0, 0, 0

PRINT "Which rotation ?"
PRINT "(X/Y/Z)"

DO
k$= UCASE$(INKEY$) LOOP UNTIL k$ = "X" OR k$= "Y" OR k$ = "Z"
PRINT "Rotation Selected: "; k$'Sets the option to 1, because the angle is multiplied by 1 or 0 to tell 'Draw3D the rotation. IF k$ = "X" THEN XXR = 1
IF k$= "Y" THEN YYR = 1 IF k$ = "Z" THEN ZZR = 1

'Call Drawing subs and rotate from 1* to 360*

'clear old one first
ClearDraw Cube()

FOR x = 1 TO 360
Draw3D Cube(), ZZR * x, XXR * x, YYR * x

'have lotsa time - wait refresh?
'Now it's commented out: for cube size ~100 it don't fast enough
'You can try if you machine is faster
'WAIT &H3DA, 8
'WAIT &H3DA, 8, 8

IF x < 360 THEN
ClearDraw Cube()
END IF
NEXT x

FUNCTION ask (b$) a$ = INPUT$(1) ask = (INSTR(b$, a$) > 0) END FUNCTION SUB ClearDraw (WF() AS Wireframe) 'clears pre-count points SHARED X2(), Y2() 'second part only: clear FOR PNT = 1 TO 8 CIRCLE (X2(PNT), Y2(PNT)), 3, 0 'Check for links, rotate them if needed, get X & Y, then draw a line. PNT2 = WF(PNT).a IF PNT2 > 0 THEN LINE (X2(PNT), Y2(PNT))-(X2(PNT2), Y2(PNT2)), 0 PNT2 = WF(PNT).b IF PNT2 > 0 THEN LINE (X2(PNT), Y2(PNT))-(X2(PNT2), Y2(PNT2)), 0 PNT2 = WF(PNT).c IF PNT2 > 0 THEN LINE (X2(PNT), Y2(PNT))-(X2(PNT2), Y2(PNT2)), 0 NEXT END SUB SUB Draw3D (WF() AS Wireframe, RZ, XR, YR) 'I suggest first rotate all points that connect it (have to save in array) 'I think it speeds things up 'cause some points rotate several times 'Or at least it would be easier to write/understand SHARED X2(), Y2() 'first part rotates FOR PNT = 1 TO 8 'Get points into 3 variables XX = WF(PNT).x YY = WF(PNT).y ZZ = WF(PNT).z 'Check for rotation parameters 'and rotate points IF RZ > 0 THEN Rot YY, XX, RZ IF XR > 0 THEN Rot YY, ZZ, XR IF YR > 0 THEN Rot XX, ZZ, YR 'Get the X and Y from x,y,z x = X2D(XX, YY, ZZ) y = Y2D(XX, YY, ZZ) 'save in array X2(PNT) = x Y2(PNT) = y 'Place a color-coded circle on the point CIRCLE (x, y), 3, PNT NEXT 'second part draw lines, uses rotated points FOR PNT = 1 TO 8 'Check for links, rotate them if needed, get X & Y, then draw a line. PNT2 = WF(PNT).a IF PNT2 > 0 THEN LINE (X2(PNT), Y2(PNT))-(X2(PNT2), Y2(PNT2)), 4 PNT2 = WF(PNT).b IF PNT2 > 0 THEN LINE (X2(PNT), Y2(PNT))-(X2(PNT2), Y2(PNT2)), 4 PNT2 = WF(PNT).c IF PNT2 > 0 THEN LINE (X2(PNT), Y2(PNT))-(X2(PNT2), Y2(PNT2)), 4 NEXT END SUB SUB fillCube (WF() AS Wireframe) 'fills coords. All things in range -100..100 'now fill ajacents FOR pt1 = 0 TO 7 i = pt1 MOD 2: j = (pt1 \ 2) MOD 2: k = (pt1 \ 4) MOD 2 x = 100 * i - 50 y = 100 * j - 50 z = 100 * k - 50 n = pt1 + 1 WF(n).x = x WF(n).y = y WF(n).z = z 'PRINT pt1, i, j, k cnt = 0 FOR pt2 = 0 TO 7 IF pt1 <> pt2 THEN i2 = pt2 MOD 2: j2 = (pt2 \ 2) MOD 2: k2 = (pt2 \ 4) MOD 2 cond = ABS(i - i2) + ABS(j - j2) + ABS(k - k2) IF cond = 1 THEN cnt = cnt + 1 ' PRINT pt1, pt2 SELECT CASE cnt CASE 1: WF(n).a = pt2 + 1 CASE 2: WF(n).b = pt2 + 1 CASE 3: WF(n).c = pt2 + 1 END SELECT END IF END IF NEXT NEXT END SUB FUNCTION iif$ (cond, yes$, no$)
IF cond THEN
iif$= yes$
ELSE
iif$= no$
END IF
END FUNCTION

SUB Rot (y, x, R)
'that's essentially copy of RZ sub (working one)
'rotates into XY plane by R degrees
XX = x * c - y * s
YY = x * s + y * c
x = XX
y = YY
END SUB

FUNCTION X2D (x, y, z)
factor = 1
IF isDimetry THEN
IF usePerspective THEN factor = (1 - z * sqr2half / 600)
X2D = (x - z * sqr2half) / factor
ELSE  'izometry
IF usePerspective THEN factor = (1 - (z + x) / 600)
X2D = ((x - z) * sqr3half) / factor
END IF
END FUNCTION

FUNCTION Y2D (x, y, z)
factor = 1
IF isDimetry THEN
IF usePerspective THEN factor = (1 - z * sqr2half / 600)
Y2D = (y - z * sqr2half) / factor
ELSE  'izometry
IF usePerspective THEN factor = (1 - (z + x) / 600)
Y2D = (y - (x + z) / 2) / factor
END IF
END FUNCTION

Hope this could help.

Here are the Subs I created and use for 3D...

You can use anything from this that you want...

I ripped them out of my Ghost Cube Program, so if I left any thing out let me know I just started Re-Optimizing it, so if you don't understand something just ask...

*Note: I originally wrote this code about 4 or 5 years ago, so it might take me a minute to remember WHY i did certain things in these subs, but the method works pretty good...

TYPE PTYPE
X AS SINGLE     'X coord
Y AS SINGLE     'Y coord
Z AS SINGLE     'Z coord
XX AS INTEGER
YY AS INTEGER
DRW AS INTEGER
END TYPE

TYPE XYTYPE
A AS INTEGER 'Point A
b AS INTEGER 'Point B
END TYPE

TYPE CTYPE
r AS PTYPE    'Rotation
O AS PTYPE    'Offset
NC AS INTEGER 'Num lines
NP AS INTEGER 'Num Points
END TYPE

DIM SHARED OBJ3D AS CTYPE, SINT(360) AS SINGLE, COST(360)  AS SINGLE

'.... Setup stuff ....

REDIM SHARED OBJ3DP(OBJ3D.NP) AS PTYPE
REDIM SHARED OBJ3DC(OBJ3D.NC) AS XYTYPE

FOR N = 0 TO 360
NEXT

SUB ROTATE (P() AS PTYPE, C AS CTYPE)
FOR N% = 1 TO C.NP
ROTX P(N%).X, P(N%).Y, P(N%).Z, C.r.X
ROTY P(N%).X, P(N%).Y, P(N%).Z, C.r.Y
ROTZ P(N%).X, P(N%).Y, P(N%).Z, C.r.Z
'Translate the 3D points to 2D coords in perspective
P(N%).XX = INT((128 * P(N%).X) / (C.O.Z - P(N%).Z)) + C.O.X
P(N%).YY = INT((128 * P(N%).Y) / (C.O.Z - P(N%).Z)) + C.O.Y
NEXT
C.r.X = 0
C.r.Y = 0
C.r.Z = 0
END SUB

SUB ROTX (X, Y, Z, D)
DCS D, CA, SA
T = Y * CA - Z * SA
Z = Z * CA + Y * SA
Y = T
END SUB

SUB ROTY (X, Y, Z, D)
DCS D, CA, SA
T = X * CA + Z * SA
Z = Z * CA - X * SA
X = T
END SUB

SUB ROTZ (X, Y, Z, D)
DCS D, CA, SA
T = X * CA - Y * SA
Y = Y * CA + X * SA
X = T
END SUB

SUB DCS (D, CA, SA) 'Degree, Cosine, Sine
ANG = INT(D MOD 360)
IF ANG < 0 THEN ANG = ANG + 360
CA = COST(ANG)
SA = SINT(ANG)
END SUB

SUB DRAWOBJ (P() AS PTYPE, C AS CTYPE, L() AS XYTYPE, CLR)
FOR N = 1 TO C.NC
A1 = P(L(N).A).XX
B1 = P(L(N).A).YY
A2 = P(L(N).b).XX
B2 = P(L(N).b).YY
LINE(A1, B1)-(A2, B2), CLR
NEXT
END SUB

Have Fun, Be Young... Code BASIC
-Josh http://cubee.topcities.com

PROGRAMMER: (n) Red-eyed, mumbling mammal capable of conversing with inanimate objects.

Here is my personal rotational code that rotates around all 3 axies. I just created this now so it is not my best code and I have not tested this to see if it works

dim pts as integer
pts = 4
dim c(360),s(360)
dim x(pts),y(pts),z(pts)
dim x2(pts),y2(pts),z2(pts)
dim x3&(pts),y3&(pts)

'cos and sin values stored for quick access
for i = 0 to 360
c(i) = cos(i * 3.14 / 180)
s(i) = sin(i * 3.14 / 180)
next

'starting angles to which the object rotates
t = 360
p = 360
d = 360

'screen starting values
xc = 160
yc = 100
zc = 50

x(1)= 10
x(2)= 10
x(3)= -10
x(4)= -10
y(1)= 10
y(2)= -10
y(3)= 10
y(4)= -10
z(1)= 0
z(2)= 0
z(3)= 0
z(4)= 0

screen 7,0,1,0

DO
PRESS$=INKEY$

a = c(p) * c(d)
b = c(p) * s(d)
c = (s(p) * s(t) * c(d) - c(t) * s(d))
de = (s(p) * s(t) * s(d) + c(t) * c(d))
e = c(p) * s(t)
f = (s(p) * c(t) * c(d) + s(t) * s(d))
g = (s(p) * c(t) * s(d) - s(d) * c(d))
h = c(p) * c(t)

cls
FOR i = 1 TO pts
x2(i) = x(i) * a + y(i) * b - z(i) * s(p)
y2(i) = x(i) * c + y(i) * de + z(i) * e
z2(i) = x(i) * f + y(i) * g + z(i) * h

x3&(i) = 256 * (x2(i) / (z2(i) + zc)) + xc
y3&(i) = 256 * (y2(i) / (z2(i) + zc)) + yc
PSET (x3&(i), y3&(i)), 15
NEXT

PCOPY 1,0
'increments the angles by one
p = p + 1
t = t + 1
d = d + 1

'if angle >360 then it is set to be below this won't
'work for negative angles
p = p mod 360
t = t mod 360
d = d miod 360

'exit the program when the ESC key is pressed
LOOP UNTIL PRESS$=CHR$(27)

#### Red Flag This Post

Please let us know here why this post is inappropriate. Reasons such as off-topic, duplicates, flames, illegal, vulgar, or students posting their homework.

#### Red Flag Submitted

Thank you for helping keep Tek-Tips Forums free from inappropriate posts.
The Tek-Tips staff will check this out and take appropriate action.

Close Box

# Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

• Talk To Other Members
• Notification Of Responses To Questions
• Favorite Forums One Click Access
• Keyword Search Of All Posts, And More...

Register now while it's still free!