THE PAST MASTER CLUB

 
'FOR RED/BLUE (STERIOSCOPIC)  GLASSES
' 3DCUBES.BAS  VERS 2.5   by: NICK K. VAN VLIET  JAN/97 SEPT/98
' CUBE 
' OFFSET 30 AND ANGLE 8 SEEMS BEST
' WEARING A RED/BLUE MASK A SQ. IS SEEN MIDWAY TWEEN SCREEN AND EYES!
' P=PAUAE U/D-RAISES/LOWERS ANGLE L/R- OFFSETS LEFT-BLUE CUBE
' PERSPECTIVE SEEMS OFF
' BECAUSE THE EYES ARE NOT FOCUSED WIDE APART -DISTANT BUT
' ALMOST CROSSWISE -CLOSE UP THUS THE ANGLE OF THE EYES TRANSALATES
' NEARNES OR DISTANCE
' THIS WAY YOU CAN GET LARGE OBJECTS

' IF YOU LOOK AT CONSECUTIVE FILM FRAMES (OR EVERY OTHER ONE) LIKE A STERIO-
' SCOPIC VIEW THEN AS LONG AS THERE IS MOTION IN IT YOU WILL SEE A 3D PRO-
' JECTION!

'
DEFINT H-Z                                      'integer      
DEFDBL A-G
TYPE COORD
     X AS DOUBLE
     Y AS DOUBLE
     Z AS DOUBLE
END TYPE

DECLARE FUNCTION GetKeys ()                   'keyboard
DECLARE SUB DrawCircle (xx, yy, CLR)
DECLARE SUB TranslateY (Rotation)             'sterio
DECLARE SUB TranslateX ()                     'rot'n x
DECLARE SUB TranslateXY ()                    'rot'n y
DECLARE SUB TranslateZ ()                     'rot'n z
DECLARE SUB PRSPCTV (CUBE() AS COORD)         'perspective factor
DECLARE SUB FACE (CUBE() AS COORD, R, S, T, U, X0, Y0, CLR, LTR$)
                                              'each facet
DECLARE SUB DrawCubes (CUBE() AS COORD, X0, Y0, CLR)    'SUB draw  a cube
DECLARE SUB BlankCubes (CUBE() AS COORD, X0, Y0)    'SUB blank a cube
CONST PI = 3.141592654#         'PI /7 = 0.44880  super novas
CONST E = 36                    'SQ scale factor    55
CONST scale = 36 * .9           'SIRC  "    "
COMMON SHARED Xstart, Xstep, Xend, Xmax, xx, yy, zz
COMMON SHARED Ystart, Ystep, Yend, Ymax
COMMON SHARED ZoomX, ZoomY, ix, iy, mix, miy, OFFSET, NN
COMMON SHARED LeftCube() AS COORD, RightCube() AS COORD, CUBE() AS COORD
COMMON SHARED X0, Y0, H, K, A$, R, S, T, U, CLR, LTR$, WRFRM$

SCREEN 13                                        '320x200  256 colors

CLS

DIM LeftCube(1 TO 8) AS COORD
DIM RightCube(1 TO 8) AS COORD
DIM CUBE(1 TO 8) AS COORD                       '??WORKS WITHOUT IT
DIM Org(1 TO 8) AS COORD

A$ = "                                                                      "

FOR I = 1 TO 8
        READ A, B, C
        LeftCube(I).X = A * E
        LeftCube(I).Y = B * E
        LeftCube(I).Z = C * E
NEXT I

MaxMX = 319: MaxMY = 199                         'full screen
WRFRM$ = "ON": SEGMENT = MaxMX / 4 + 40: OFFSET = 20                             'WIRE FROME ON/OFF
R = 1: L = 1:  H = 10: K = 20
NN = 10                                         'rotation in degrees

TranslateXY                            'translate LeftCube K degrees Z-AXIS

DrawCircle SEGMENT, MaxMY / 2, 1
DrawCircle SEGMENT + OFFSET - 10, MaxMY / 2, 4
INC = -4
MX = 20
TTL = MX


DO

TTL = TTL + INC: ''LOCATE 1, 1: PRINT TTL; "        "; INC; "   "

IF TTL < 0 OR TTL > MX * 2 THEN INC = -INC

TranslateX                            'translate LeftCube H degrees X-AXIS
TranslateXY                            'translate LeftCube K degrees Z-AXIS

FOR I = 1 TO 8
     Org(I).X = LeftCube(I).X
     Org(I).Y = LeftCube(I).Y
     Org(I).Z = LeftCube(I).Z
NEXT I
TranslateY NN                           'translate LeftCube 10 degrees
PRSPCTV LeftCube()
DrawCubes LeftCube(), SEGMENT, MaxMY / 2, 1  'Left 3D Cube BLUE -SEEN THRU RED
PRSPCTV RightCube()
DrawCubes RightCube(), SEGMENT + OFFSET + TTL - MX * 1.5, MaxMY / 2, 4'Right 3D Cube RED =" BLUE
   LOCATE 1, 1
   ' PRINT "OFFSET= "; OFFSET + TTL - MX*2; " ANGLE= "; NN
   IF INKEY$ = "P" THEN LOCATE 2, 1: INPUT U$

FOR LL = 0 TO 1000: FOR LM = 0 TO 50: NEXT LM: NEXT LL 'INPUT U$
BlankCubes LeftCube(), SEGMENT, MaxMY / 2
BlankCubes RightCube(), SEGMENT + OFFSET + TTL - MX * 1.5, MaxMY / 2
W = GetKeys

FOR I = 1 TO 8
    LeftCube(I).X = Org(I).X
    LeftCube(I).Y = Org(I).Y
    LeftCube(I).Z = Org(I).Z
NEXT I


LOOP WHILE KeyVal <> 27               'keep going until escape is pressed

END
DATA -1 , -1 , -1, -1 , +1 , -1, -1 , +1 , +1, -1 , -1 , +1, +1 , -1 , +1, +1 , +1 , +1, +1 , +1 , -1, +1 , -1 , -1
DATA 0,0,0

SUB BlankCubes (CUBE() AS COORD, X0, Y0)
LINE (CUBE(1).X + X0, CUBE(1).Y + Y0)-(CUBE(2).X + X0, CUBE(2).Y + Y0), 0 'left face
LINE (CUBE(2).X + X0, CUBE(2).Y + Y0)-(CUBE(3).X + X0, CUBE(3).Y + Y0), 0
LINE (CUBE(3).X + X0, CUBE(3).Y + Y0)-(CUBE(4).X + X0, CUBE(4).Y + Y0), 0
LINE (CUBE(4).X + X0, CUBE(4).Y + Y0)-(CUBE(1).X + X0, CUBE(1).Y + Y0), 0

LINE (CUBE(5).X + X0, CUBE(5).Y + Y0)-(CUBE(6).X + X0, CUBE(6).Y + Y0), 0 'right face
LINE (CUBE(6).X + X0, CUBE(6).Y + Y0)-(CUBE(7).X + X0, CUBE(7).Y + Y0), 0
LINE (CUBE(7).X + X0, CUBE(7).Y + Y0)-(CUBE(8).X + X0, CUBE(8).Y + Y0), 0
LINE (CUBE(8).X + X0, CUBE(8).Y + Y0)-(CUBE(5).X + X0, CUBE(5).Y + Y0), 0

LINE (CUBE(2).X + X0, CUBE(2).Y + Y0)-(CUBE(3).X + X0, CUBE(3).Y + Y0), 0 'top face
LINE (CUBE(3).X + X0, CUBE(3).Y + Y0)-(CUBE(6).X + X0, CUBE(6).Y + Y0), 0
LINE (CUBE(6).X + X0, CUBE(6).Y + Y0)-(CUBE(7).X + X0, CUBE(7).Y + Y0), 0
LINE (CUBE(7).X + X0, CUBE(7).Y + Y0)-(CUBE(2).X + X0, CUBE(2).Y + Y0), 0

LINE (CUBE(1).X + X0, CUBE(1).Y + Y0)-(CUBE(4).X + X0, CUBE(4).Y + Y0), 0 'bottom face
LINE (CUBE(4).X + X0, CUBE(4).Y + Y0)-(CUBE(5).X + X0, CUBE(5).Y + Y0), 0
LINE (CUBE(5).X + X0, CUBE(5).Y + Y0)-(CUBE(8).X + X0, CUBE(8).Y + Y0), 0
LINE (CUBE(8).X + X0, CUBE(8).Y + Y0)-(CUBE(1).X + X0, CUBE(1).Y + Y0), 0

LINE (CUBE(3).X + X0, CUBE(3).Y + Y0)-(CUBE(4).X + X0, CUBE(4).Y + Y0), 0 'front face
LINE (CUBE(4).X + X0, CUBE(4).Y + Y0)-(CUBE(5).X + X0, CUBE(5).Y + Y0), 0
LINE (CUBE(5).X + X0, CUBE(5).Y + Y0)-(CUBE(6).X + X0, CUBE(6).Y + Y0), 0
LINE (CUBE(6).X + X0, CUBE(6).Y + Y0)-(CUBE(3).X + X0, CUBE(3).Y + Y0), 0

LINE (CUBE(1).X + X0, CUBE(1).Y + Y0)-(CUBE(2).X + X0, CUBE(2).Y + Y0), 0 'rear face
LINE (CUBE(2).X + X0, CUBE(2).Y + Y0)-(CUBE(7).X + X0, CUBE(7).Y + Y0), 0
LINE (CUBE(7).X + X0, CUBE(7).Y + Y0)-(CUBE(8).X + X0, CUBE(8).Y + Y0), 0
LINE (CUBE(8).X + X0, CUBE(8).Y + Y0)-(CUBE(1).X + X0, CUBE(1).Y + Y0), 0

END SUB

SUB DrawCircle (xx, yy, CLR)
x1 = 3 * scale
y1 = 0
FOR II = 0 TO 361
x2 = 3 * scale * COS(II / 180 * PI)
y2 = 3 * scale * SIN(II / 180 * PI)
LINE (x1 + xx, y1 + yy)-(x2 + xx, y2 + yy), CLR
x1 = x2: y1 = y2
NEXT II
'
END SUB

SUB DrawCubes (CUBE() AS COORD, X0, Y0, CLR)
LOCATE 1, 1
COLOR 2
FACE CUBE(), 1, 2, 3, 4, X0, Y0, CLR, "L"   'left 13?  2=GREEN
COLOR 3
FACE CUBE(), 5, 6, 7, 8, X0, Y0, CLR, "R"   'right 14=YELLOW 3=CYAN
COLOR 4
FACE CUBE(), 2, 3, 6, 7, X0, Y0, CLR, "T"   '/top 12=BRED  4=RED
COLOR 5
FACE CUBE(), 1, 4, 5, 8, X0, Y0, CLR, "U"   '/bottom  10=PINK 5=MAGENENTA
COLOR 9
FACE CUBE(), 3, 4, 5, 6, X0, Y0, CLR, "F"   '/front 9=BLUE     6=DGREY
COLOR 7
FACE CUBE(), 1, 2, 7, 8, X0, Y0, CLR, "B"   '/rear  11=BGREEN 7=GREY
COLOR 15
END SUB

SUB FACE (CUBE() AS COORD, R, S, T, U, X0, Y0, CLR, LTR$)
COLOR CLR
F = (CUBE(R).Z + CUBE(T).Z + CUBE(S).Z + CUBE(U).Z) / 4
IF WRFRM$ = "ON" THEN D = 1 ELSE D = 0         'WIRE FRAME
IF D = 0 THEN
IF F < -1 THEN
LOCATE (((CUBE(T).Y + CUBE(R).Y) / 2 + Y0) / 8) + 1, (((CUBE(T).X + CUBE(R).X) / 2 + X0) / 8) + 1
LINE (CUBE(R).X + X0, CUBE(R).Y + Y0)-(CUBE(U).X + X0, CUBE(U).Y + Y0), CLR
LINE (CUBE(S).X + X0, CUBE(S).Y + Y0)-(CUBE(R).X + X0, CUBE(R).Y + Y0), CLR
LINE (CUBE(T).X + X0, CUBE(T).Y + Y0)-(CUBE(S).X + X0, CUBE(S).Y + Y0), CLR
LINE (CUBE(U).X + X0, CUBE(U).Y + Y0)-(CUBE(T).X + X0, CUBE(T).Y + Y0), CLR
LOCATE (((CUBE(T).Y + CUBE(R).Y) / 2 + Y0) / 8) + 1, (((CUBE(T).X + CUBE(R).X) / 2 + X0) / 8) + 1
END IF
ELSE
LINE (CUBE(R).X + X0, CUBE(R).Y + Y0)-(CUBE(U).X + X0, CUBE(U).Y + Y0), CLR
LINE (CUBE(S).X + X0, CUBE(S).Y + Y0)-(CUBE(R).X + X0, CUBE(R).Y + Y0), CLR
LINE (CUBE(T).X + X0, CUBE(T).Y + Y0)-(CUBE(S).X + X0, CUBE(S).Y + Y0), CLR
LINE (CUBE(U).X + X0, CUBE(U).Y + Y0)-(CUBE(T).X + X0, CUBE(T).Y + Y0), CLR
END IF
END SUB

FUNCTION GetKeys
K$ = INKEY$: H = 0: K = 0
GetKeyMask = 0
IF K$ = "D" OR K$ = "U" OR K$ = "L" OR K$ = "R" THEN
  LOCATE 2, 1
   'PRINT K$; "                < STR = ";
   GetKeyMask = 1
   IF K$ = "L" THEN OFFSET = OFFSET - 1 ELSE IF K$ = "R" THEN OFFSET = OFFSET + 1
   IF K$ = "D" THEN NN = NN - 1 ELSE IF K$ = "U" THEN NN = NN + 1

END IF
DO
H = rand * 5 - 10
K = rand * 2 - 4
LOOP UNTIL (H OR K)              'WAIT TILL KEY PRESSED
GetKeys = H OR K
END FUNCTION

SUB PRSPCTV (CUBE() AS COORD)
D = -600                                     'LESS GIVES INNER LINES
FOR I = 1 TO 8
A = CUBE(I).X
AA = ABS(A)
IF A = 0 THEN S = 1 ELSE S = A / AA
B = -CUBE(I).Z + D                          'PERSPECTIVE VIEW POINT D=600=Z'
C = AA / D * B * S                                  'AND WITH E=20 BEST
CUBE(I).X = C
NEXT I
FOR I = 1 TO 8
A = CUBE(I).Y
AA = ABS(A)
IF A = 0 THEN S = 1 ELSE S = A / AA
B = -CUBE(I).Z + D
C = AA / D * B * S
CUBE(I).Y = C
NEXT I
END SUB

SUB TranslateX
LOCATE 1, 1
A = COS(CDBL(H) * PI / 180#)
B = SIN(CDBL(H) * PI / 180#)
FOR I = 1 TO 8
LOCATE 2, 1
C = LeftCube(I).Y * A + LeftCube(I).Z * B
LeftCube(I).Z = -LeftCube(I).Y * B + LeftCube(I).Z * A
LeftCube(I).Y = C
LeftCube(I).X = LeftCube(I).X
NEXT I
END SUB

SUB TranslateXY
LOCATE 1, 1
A = COS(K * PI / 180)
B = SIN(K * PI / 180)
FOR I = 1 TO 8
LOCATE 3, 1
C = LeftCube(I).X * A + LeftCube(I).Z * B
LeftCube(I).Z = -LeftCube(I).X * B + LeftCube(I).Z * A
LeftCube(I).X = C
LeftCube(I).Y = LeftCube(I).Y
NEXT I
END SUB

SUB TranslateY (Rotation)
A = COS(Rotation * PI / 180)
B = SIN(Rotation * PI / 180)
FOR I = 1 TO 8
RightCube(I).X = LeftCube(I).X * A + LeftCube(I).Z * B
RightCube(I).Z = -LeftCube(I).X * B + LeftCube(I).Z * A
RightCube(I).Y = LeftCube(I).Y
NEXT I
END SUB

SUB TranslateZ
A = COS(CDBL(K) * PI / 180#)
B = SIN(CDBL(K) * PI / 180#)
FOR I = 1 TO 8
C = LeftCube(I).X * A + LeftCube(I).Y * B
LeftCube(I).Y = -LeftCube(I).X * B + LeftCube(I).Y * A
LeftCube(I).X = C
LeftCube(I).Z = LeftCube(I).Z
NEXT I
END SUB