'===========================================================================
' Subject: ROTATING 3D CYLINDER & SPHERE     Date: 10-22-96 (17:52)       
' Author:  Douglas H. Lusher                 Code: QB, QBasic, PDS        
' Origin:  comp.lang.basic.misc            Packet: GRAPHICS.ABC
'===========================================================================
'this is code to draw and rotate a 3-d image of a cylinder
'  and a sphere.
'by Douglas H. Lusher, October 1996
DECLARE SUB DrawPoly (X%(), Y%(), Vertices%, Culler%)
DECLARE FUNCTION KeyPress% ()
CONST Green = 2, White = 15
CONST ESC = 27
CONST HomeKey = -71, EndKey = -79
CONST UpArrow = -72, DnArrow = -80
CONST LArrow = -75,  RArrow = -77
'the home key brings the object toward the viewer, the end key
'   takes it away from the viewer.
'the up arrow moves the object up, the down arrow moves it down,
'   the right arrow moves it right, the left arrow moves it left.
'pressing "y","p", or "r" increases yaw, pitch and roll respectively.
'   pressing the uppercase of these letters decreases the values.
RANDOMIZE TIMER
APage% = 1: VPage% = 0
SCREEN 9, , APage%, VPage%
ScrnWid% = 640: ScrnHgt% = 350
CtrX% = ScrnWid% \ 2: CtrY% = ScrnHgt% \ 2
AspectRatio! = 4 * (ScrnHgt% / ScrnWid%) / 3
Pi! = ATN(1) * 4!

DO: R1! = RND: LOOP UNTIL R1! < .628: R1! = R1! * 10!
DO: R2! = RND: LOOP UNTIL R2! < .628: R2! = R2! * 10!
DO: R3! = RND: LOOP UNTIL R3! < .628: R3! = R3! * 10!
'R1! = 0: R2! = 0: R3! = 0
D! = 1200
MX! = 0: MY! = 0: MZ! = -350
Inc! = .02
RInc! = -Inc!
PInc! = -Inc!
YInc! = -Inc!

GOSUB InitCylinder
'GOSUB InitSphere

'MainLoop
DO
  SELECT CASE KeyPress%
    CASE 0
    CASE UpArrow: MY! = MY! + 10!
    CASE DnArrow: MY! = MY! - 10!
    CASE LArrow: MX! = MX! + 10!
    CASE RArrow: MX! = MX! - 10!
    CASE HomeKey: MZ! = MZ! + 10!
    CASE EndKey: MZ! = MZ! - 10!
    CASE ASC("r")
      RInc! = RInc! + Inc!: IF RInc! > 1 THEN RInc! = 1
    CASE ASC("R")
      RInc! = RInc! - Inc!: IF RInc! < -1 THEN RInc! = -1
    CASE ASC("y")
      YInc! = YInc! + Inc!: IF YInc! > 1 THEN YInc! = 1
    CASE ASC("Y")
      YInc! = YInc! - Inc!: IF YInc! < -1 THEN YInc! = -1
    CASE ASC("p")
      PInc! = PInc! + Inc!: IF PInc! > 1 THEN PInc! = 1
    CASE ASC("P")
      PInc! = PInc! - Inc!: IF PInc! < -1 THEN PInc! = -1
    CASE ESC: EXIT DO
  END SELECT
  R1! = R1! + YInc!: IF R1! > 6.28 THEN R1! = 0
  R2! = R2! + RInc!: IF R2! > 6.28 THEN R2! = 0
  R3! = R3! + PInc!: IF R3! > 6.28 THEN R3! = 0
  SR1! = SIN(R1!): CR1! = COS(R1!)
  SR2! = SIN(R2!): CR2! = COS(R2!)
  SR3! = SIN(R3!): CR3! = COS(R3!)
  CLS
  GOSUB DrawCylinder
  'GOSUB DrawSphere
  SWAP APage%, VPage%
  WAIT &H3DA, 8
  SCREEN , , APage%, VPage%
LOOP
SCREEN 0: WIDTH 80
END
  
PerspectiveCalculations:
X! = -X!
XA! = CR1! * X! - SR1! * Z!
ZA! = SR1! * X! + CR1! * Z!
X! = CR2! * XA! + SR2! * Y!
YA! = CR2! * Y! - SR2! * XA!
Z! = CR3! * ZA! - SR3! * YA!
Y! = SR3! * ZA! + CR3! * YA!
X! = X! + MX!
Y! = Y! + MY!
Z! = Z! + MZ!
SX% = CINT(D! * X! / Z!) + CtrX%
SY% = CINT(D! * Y! / Z! * AspectRatio!) + CtrY%
RETURN

CheckVisibility:
'plane equation method of hidden surface removal
SP1! = -X1! * (Y2! * Z3! - Y3! * Z2!)
SP2! = X2! * (Y3! * Z1! - Y1! * Z3!)
SP3! = X3! * (Y1! * Z2! - Y2! * Z1!)
VisibleSurface% = ((SP1! - SP2! - SP3!) <= 0)
RETURN

'========================================================================
InitCylinder:
L! = 40!     'half the length of the cylinder
R! = 20!     'the radius of the cylinder
Divs% = 18   'the number of steps around the cylinder
StepAmount! = (Pi! * 2!) / CSNG(Divs%)
S1% = 1: S2% = Divs% \ 3: S3% = S2% + S2%
REDIM X1!(1 TO Divs% + 1), X2!(1 TO Divs% + 1)
REDIM Y1!(1 TO Divs% + 1), Y2!(1 TO Divs% + 1)
REDIM Z1!(1 TO Divs% + 1), Z2!(1 TO Divs% + 1)
REDIM SX1%(1 TO Divs% + 1), SY1%(1 TO Divs% + 1)
REDIM SX2%(1 TO Divs% + 1), SY2%(1 TO Divs% + 1)
REDIM X%(1 TO 4), Y%(1 TO 4)
Xtra% = Divs% + 1
RETURN

DrawCylinder:
R5! = 0
FOR T% = 1 TO Divs%
  XX! = SIN(R5!) * R!: YY! = COS(R5!) * R!
  'one end of cylinder
  X! = XX!: Y! = YY!: Z! = L!
  GOSUB PerspectiveCalculations
  X1!(T%) = X!: Y1!(T%) = Y!: Z1!(T%) = Z!
  SX1%(T%) = SX%: SY1%(T%) = SY%
  'other end of cylinder
  X! = XX!: Y! = YY!: Z! = -L!
  GOSUB PerspectiveCalculations
  X2!(T%) = X!: Y2!(T%) = Y!: Z2!(T%) = Z!
  SX2%(T%) = SX%: SY2%(T%) = SY%
  R5! = R5! + StepAmount!
NEXT
X1!(Xtra%) = X1!(1): X2!(Xtra%) = X2!(1)
Y1!(Xtra%) = Y1!(1): Y2!(Xtra%) = Y2!(1)
Z1!(Xtra%) = Z1!(1): Z2!(Xtra%) = Z2!(1)
SX1%(Xtra%) = SX1%(1): SX2%(Xtra%) = SX2%(1)
SY1%(Xtra%) = SY1%(1): SY2%(Xtra%) = SY2%(1)
FOR Q1% = 1 TO Divs%          'draw the side polygons of the cylinder
  Q2% = Q1% + 1
  X1! = X1!(Q1%): Y1! = Y1!(Q1%): Z1! = Z1!(Q1%)
  X2! = X1!(Q2%): Y2! = Y1!(Q2%): Z2! = Z1!(Q2%)
  X3! = X2!(Q2%): Y3! = Y2!(Q2%): Z3! = Z2!(Q2%)
  GOSUB CheckVisibility
  IF VisibleSurface% THEN
    X%(1) = SX1%(Q1%): Y%(1) = SY1%(Q1%)
    X%(2) = SX1%(Q2%): Y%(2) = SY1%(Q2%)
    X%(3) = SX2%(Q2%): Y%(3) = SY2%(Q2%)
    X%(4) = SX2%(Q1%): Y%(4) = SY2%(Q1%)
    CALL DrawPoly(X%(), Y%(), 4, White)
  END IF
NEXT
'draw one end
X1! = X1!(S1%): Y1! = Y1!(S1%): Z1! = Z1!(S1%)
X2! = X1!(S3%): Y2! = Y1!(S3%): Z2! = Z1!(S3%)
X3! = X1!(S2%): Y3! = Y1!(S2%): Z3! = Z1!(S2%)
GOSUB CheckVisibility
IF VisibleSurface% THEN
  CALL DrawPoly(SX1%(), SY1%(), Divs%, White)
END IF
'draw the other end
X1! = X2!(S1%): Y1! = Y2!(S1%): Z1! = Z2!(S1%)
X2! = X2!(S2%): Y2! = Y2!(S2%): Z2! = Z2!(S2%)
X3! = X2!(S3%): Y3! = Y2!(S3%): Z3! = Z2!(S3%)
GOSUB CheckVisibility
IF VisibleSurface% THEN
  CALL DrawPoly(SX2%(), SY2%(), Divs%, White)
END IF
RETURN

'========================================================================
InitSphere:
R! = 40!            'the radius of the sphere
Divs% = 18
StepAmount! = (Pi! * 2!) / CSNG(Divs%)
REDIM X1!(1 TO Divs% + 1), X2!(1 TO Divs% + 1)
REDIM Y1!(1 TO Divs% + 1), Y2!(1 TO Divs% + 1)
REDIM Z1!(1 TO Divs% + 1), Z2!(1 TO Divs% + 1)
REDIM SX1%(1 TO Divs% + 1), SY1%(1 TO Divs% + 1)
REDIM SX2%(1 TO Divs% + 1), SY2%(1 TO Divs% + 1)
REDIM X%(1 TO 4), Y%(1 TO 4)
Xtra% = Divs% + 1
RETURN

DrawSphere:
'north polar area
'R5! = 0: X! = SIN(R5!) * R!: Y! = COS(R5!) * R!: Z! = 0
X! = 0!: Y! = R!: Z! = 0
GOSUB PerspectiveCalculations
X3! = X!: Y3! = Y!: Z3! = Z!
X%(3) = SX%: Y%(3) = SY%
R5! = StepAmount!: GOSUB CalcAround
FOR Q1% = 1 TO Divs%
  Q2% = Q1% + 1
  X1! = X2!(Q2%): Y1! = Y2!(Q2%): Z1! = Z2!(Q2%)
  X2! = X2!(Q1%): Y2! = Y2!(Q1%): Z2! = Z2!(Q1%)
  GOSUB CheckVisibility
  IF VisibleSurface% THEN
    X%(1) = SX2%(Q2%): Y%(1) = SY2%(Q2%)
    X%(2) = SX2%(Q1%): Y%(2) = SY2%(Q1%)
    CALL DrawPoly(X%(), Y%(), 3, Green)
  END IF
NEXT

'middle of sphere
R5! = StepAmount!
FOR T2% = 1 TO (Divs% \ 2) - 2
  FOR Q1% = 1 TO Divs% + 1
    X1!(Q1%) = X2!(Q1%): Y1!(Q1%) = Y2!(Q1%): Z1!(Q1%) = Z2!(Q1%)
    SX1%(Q1%) = SX2%(Q1%): SY1%(Q1%) = SY2%(Q1%)
  NEXT
  R5! = R5! + StepAmount!: GOSUB CalcAround
  FOR Q1% = 1 TO Divs%
    Q2% = Q1% + 1
    X1! = X1!(Q1%): Y1! = Y1!(Q1%): Z1! = Z1!(Q1%)
    X2! = X1!(Q2%): Y2! = Y1!(Q2%): Z2! = Z1!(Q2%)
    X3! = X2!(Q2%): Y3! = Y2!(Q2%): Z3! = Z2!(Q2%)
    GOSUB CheckVisibility
    IF VisibleSurface% THEN
      X%(1) = SX1%(Q1%): Y%(1) = SY1%(Q1%)
      X%(2) = SX1%(Q2%): Y%(2) = SY1%(Q2%)
      X%(3) = SX2%(Q2%): Y%(3) = SY2%(Q2%)
      X%(4) = SX2%(Q1%): Y%(4) = SY2%(Q1%)
      CALL DrawPoly(X%(), Y%(), 4, Green)
    END IF
  NEXT
NEXT

'south polar area
R5! = Pi!: X! = SIN(R5!) * R!: Y! = COS(R5!) * R!: Z! = 0
GOSUB PerspectiveCalculations
X3! = X!: Y3! = Y!: Z3! = Z!
X%(3) = SX%: Y%(3) = SY%
FOR Q1% = 1 TO Divs%
  Q2% = Q1% + 1
  X1! = X2!(Q1%): Y1! = Y2!(Q1%): Z1! = Z2!(Q1%)
  X2! = X2!(Q2%): Y2! = Y2!(Q2%): Z2! = Z2!(Q2%)
  GOSUB CheckVisibility
  IF VisibleSurface% THEN
    X%(1) = SX2%(Q2%): Y%(1) = SY2%(Q2%)
    X%(2) = SX2%(Q1%): Y%(2) = SY2%(Q1%)
    CALL DrawPoly(X%(), Y%(), 3, Green)
  END IF
NEXT
RETURN

CalcAround:
R4! = 0!: XX! = SIN(R5!) * R!: YY! = COS(R5!) * R!
FOR T% = 1 TO Divs%
  X! = COS(R4!) * XX!: Y! = YY!: Z! = SIN(R4!) * XX!
  GOSUB PerspectiveCalculations
  X2!(T%) = X!: Y2!(T%) = Y!: Z2!(T%) = Z!
  SX2%(T%) = SX%: SY2%(T%) = SY%
  R4! = R4! + StepAmount!
NEXT
X1!(Xtra%) = X1!(1): X2!(Xtra%) = X2!(1)
Y1!(Xtra%) = Y1!(1): Y2!(Xtra%) = Y2!(1)
Z1!(Xtra%) = Z1!(1): Z2!(Xtra%) = Z2!(1)
SX1%(Xtra%) = SX1%(1): SX2%(Xtra%) = SX2%(1)
SY1%(Xtra%) = SY1%(1): SY2%(Xtra%) = SY2%(1)
RETURN

SUB DrawPoly (X%(), Y%(), Vertices%, Culler%)
PSET (X%(Vertices%), Y%(Vertices%)), Culler%
FOR Q% = 1 TO Vertices%
  LINE -(X%(Q%), Y%(Q%)), Culler%
NEXT
END SUB

FUNCTION KeyPress%
KP$ = INKEY$
IF LEN(KP$) THEN 
  KP% = ASC(KP$): IF KP% = 0 THEN KP% = -ASC(MID$(KP$, 2))
END IF
KeyPress% = KP%
END FUNCTION