'===========================================================================
' Subject: ROTATING 3D PLANE                 Date: 03-04-99 (00:00)       
' Author:  The ABC Programmer                Code: QB, QBasic, PDS        
' Origin:  voxel@edmc.net                  Packet: GRAPHICS.ABC
'===========================================================================
' Rotating 3D Plane (supposed to be a cube though) by William Yu
' Tried converting from Pascal, but messed up somewhere...

DECLARE SUB setpal (c%, R%, G%, B%)
DECLARE FUNCTION LShift% (byte%, Bits%)
DECLARE SUB Calcsinus (SinTab%())
DECLARE SUB quicksort (lo%, hi%)
DECLARE SUB polygon (x1%, Y1%, x2%, Y2%, x3%, Y3%, x4%, Y4%, c%)
DECLARE FUNCTION sinus% (i%)
DECLARE FUNCTION cosinus% (i%)
DECLARE SUB Rotate ()
DEFINT A-Z
''''''''''''''''''''''''''''''''''''
''program polygoned_cube;
''{ THE very first polygoned cube }
''uses crt;
''const
''  vidseg:word=$a000;
''  dist=150;
'''''''''''''''''''''''''''''''''''''
CONST dist = 150
CONST Pi = 3.141
CONST False = 0
CONST True = NOT False

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''  point:array[0..7,0..2] of integer=(
''    (-35,-35,-35),(-35,-35,35),(35,-35,35),(35,-35,-35),
''    (-35, 35,-35),(-35, 35,35),(35, 35,35),(35, 35,-35));
''  planes:array[0..5,0..3] of byte=(
''    (0,4,5,1),(0,3,7,4),(0,1,2,3),(4,5,6,7),(7,6,2,3),(1,2,6,5));
''type
''  tabtype=array[0..255] of integer;
''  planearray=array[0..5] of integer;
''var
''  sintab:tabtype;
''  planez:planearray;
''  virscr:pointer;
''  virseg:word;
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
DIM SHARED points(0 TO 7, 0 TO 2) AS INTEGER
DIM SHARED planes(0 TO 5, 0 TO 3) AS INTEGER
DIM SHARED SinTab(0 TO 255) AS INTEGER
DIM SHARED planez(0 TO 5) AS INTEGER
' virscr and virseg are not convertable, they are used to do page flipping
' in mode 13h, and would require too much memory in BASIC
' Check Andrew L. Ayers Blastlib! to work around this, or Jonathan Leger's
' EMS routines.

FOR A = 0 TO 7
  FOR B = 0 TO 2
    READ points(A, B)
  NEXT B
NEXT A

DATA -35,-35,-35,-35,-35,35,35,-35,35,35,-35,-35
DATA -35, 35,-35,-35, 35,35,35, 35,35,35, 35,-35

FOR A = 0 TO 5
  FOR B = 0 TO 3
    READ planes(A, B)
  NEXT B
NEXT A

DATA 0,4,5,1,0,3,7,4,0,1,2,3,4,5,6,7,7,6,2,3,1,2,6,5

'{----------------------------------------------------------------------------}

'** Forget converting this (most graphic routines just forget about converting)
''''''''''''''''''''''''''''''''''''''''''
''procedure cls(lvseg:word); assembler;
''asm
''  mov es,[lvseg]
''  xor di,di
''  xor ax,ax
''  mov cx,320*200/2
''  rep stosw
''end;
''''''''''''''''''''''''''''''''''''''''''

'** Simple page copy, use SCREEN 7 if you know the graphics aren't intensive.
'** Again, just forget about converting these graphic routines.
''''''''''''''''''''''''''''''''''''''''''''
''procedure flip(src,dst:word); assembler;
''asm
''  push ds
''  mov es,[dst]
''  mov ds,[src]
''  xor si,si
''  xor di,di
''  mov cx,320*200/2
''  rep movsw
''  pop ds
''end;
''''''''''''''''''''''''''''''''''''''''''''

'{----------------------------------------------------------------------------}

'{----------------------------------------------------------------------------}

'{----------------------------------------------------------------------------}

'** Never mind this, just use BASIC's LINE
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''procedure horline(xb,xe,y:integer; c:byte); assembler;
''asm
''  mov bx,[xb]
''  cmp bx,0
''  jz @out
''  mov cx,[xe]
''  jcxz @out
''  cmp bx,cx
''  jb @skip
''  xchg bx,cx
'' @skip:
''  dec bx
''  inc cx
''  sub cx,bx
''  mov es,virseg
''  mov ax,[y]
''  shl ax,6
''  mov di,ax
''  shl ax,2
''  add di,ax
''  add di,bx
''  mov al,[c]
''  shr cx,1
''  jnc @skip2
''  stosb
'' @skip2:
''  mov ah,al
''  rep stosw
'' @out:
''end;
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'{----------------------------------------------------------------------------}

'{----------------------------------------------------------------------------}

'{----------------------------------------------------------------------------}

'var i:byte;
'begin
  CALL Calcsinus(SinTab())
  'asm mov ax,13h; int 10h; end;
  SCREEN 7
'  getmem(virscr,64000);
'  virseg:=seg(virscr^);
'  cls(virseg);
  FOR i = 0 TO 5
    CALL setpal(i + 1, 10 + i * 2, 30 + i * 2, 10 + i * 2)
  NEXT i
  CALL Rotate
'  freemem(virscr,64000);
'  textmode(lastmode);

END

SUB Calcsinus (SinTab())
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''procedure Calcsinus(var SinTab : TabType); var I : byte; begin
''  for I := 0 to 255 do SinTab[I] := round(sin(2*I*pi/255)*128); end;
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'DIM I AS INTEGER  ' don't need
  FOR i = 0 TO 255
    SinTab(i) = INT(SIN(2 * i * Pi / 255) * 128)
  NEXT i
END SUB

FUNCTION cosinus% (i)
  cosinus% = SinTab((ABS(i) + 192) MOD 255)
END FUNCTION

FUNCTION LShift% (byte%, Bits%) STATIC
   LShift% = (byte% * (2 ^ Bits%)) MOD 256
END FUNCTION

SUB polygon (x1, Y1, x2, Y2, x3, Y3, x4, Y4, c)
' You don't need to put in AS INTEGER because we used DEFINT A-Z
' However, becareful if you do need to define them.
' DO NOT use X1,Y1,X2,etc. AS INTEGER, you must define them separately.
'  ie. X1 AS INTEGER, X2 AS INTEGER, etc.
''procedure polygon(x1,y1,x2,y2,x3,y3,x4,y4:integer; c:byte);
''var
''  xpos:array[0..199,0..1] of integer;
DIM XPos(0 TO 199, 0 TO 1) AS INTEGER
''  mny,mxy,y:integer;
''  i:word;
''  s1,s2,s3,s4:shortint;

''begin
''  mny:=y1;
  mny = Y1
''  if y2<mny then mny:=y2;
  IF Y2 < mny THEN mny = Y2
''  if y3<mny then mny:=y3;
  IF Y3 < mny THEN mny = Y3
''  if y4<mny then mny:=y4;
  IF Y4 < mny THEN mny = Y4
''  mxy:=y1;
  mxy = Y1
''  if y2>mxy then mxy:=y2;
  IF Y2 > mxy THEN mxy = Y2
''  if y3>mxy then mxy:=y3;
  IF Y3 > mxy THEN mxy = Y3
''  if y4>mxy then mxy:=y4;
  IF Y4 > mxy THEN mxy = Y4
''  s1:=byte(y1<y2)*2-1;
' for this, y1<y2 returns either 1 for true, or 0 for false
  IF Y1 < Y2 THEN byte = 1 ELSE byte = 0
  s1 = byte * 2 - 1
''  s2:=byte(y2<y3)*2-1;
  IF Y2 < Y3 THEN byte = 1 ELSE byte = 0
  s2 = byte * 2 - 1
''  s3:=byte(y3<y4)*2-1;
  IF Y3 < Y4 THEN byte = 1 ELSE byte = 0
  s3 = byte * 2 - 1
''  s4:=byte(y4<y1)*2-1;
  IF Y4 < Y1 THEN byte = 1 ELSE byte = 0
  s4 = byte * 2 - 1
''  y:=y1;
  Y = Y1
  IF Y1 <> Y2 THEN
    DO
      IF Y1 < Y2 THEN byte = 1 ELSE byte = 0
      XPos(Y, byte) = INT(x2 - x1) * (Y - Y1) / (Y2 - Y1) + x1
      Y = Y + s1
    LOOP UNTIL Y = Y2 + s1
  ELSE
    IF Y1 > Y2 THEN byte = 1 ELSE byte = 0
    XPos(Y, byte) = x1
  END IF
  Y = Y2
  IF Y2 <> Y3 THEN
    DO
      IF Y2 < Y3 THEN byte = 1 ELSE byte = 0
      XPos(Y, byte) = INT(x3 - x2) * (Y - Y2) / (Y3 - Y2) + x2
      Y = Y + s2
    LOOP UNTIL Y = Y3 + s2
  ELSE
    IF Y2 > Y3 THEN byte = 1 ELSE byte = 0
    XPos(Y, byte) = x2
  END IF
  Y = Y3
  IF Y3 <> Y4 THEN
    IF Y3 < Y4 THEN byte = 1 ELSE byte = 0
    DO
      XPos(Y, byte) = INT(x4 - x3) * (Y - Y3) / (Y4 - Y3) + x3
      Y = Y + s3
    LOOP UNTIL Y = Y4 + s3
  ELSE
    IF Y3 > Y4 THEN byte = 1 ELSE byte = 0
    XPos(Y, byte) = x3
  END IF
  Y = Y4
  IF Y4 <> Y1 THEN
    DO
      IF Y4 < Y1 THEN byte = 1 ELSE byte = 0
      XPos(Y, byte) = INT(x1 - x4) * (Y - Y4) / (Y1 - Y4) + x4
      Y = Y + s4
    LOOP UNTIL Y = Y1 + s4
  ELSE
    IF Y1 < Y4 THEN byte = 1 ELSE byte = 0
    XPos(Y, byte) = x4
  END IF
  FOR Y = mny TO mxy
    LINE (XPos(Y, 0), Y)-(XPos(Y, 1), Y), c
    'horline(xpos[y,0],xpos[y,1],y,c);
  NEXT Y
END SUB

SUB quicksort (lo, hi)

'procedure sort(l,r:integer);
'var i,j,x,y: integer;
'begin
  i = lo: j = hi: x = planez((lo + hi) / 2)
  DO
    WHILE planez(i) < x
      i = i + 1
    WEND
    WHILE x < planez(j)
      j = j - 1
    WEND
    IF i <= j THEN
      Y = planez(i): planez(i) = planez(j): planez(j) = Y
      i = i + 1: j = j - 1
    END IF
  LOOP UNTIL i > j
  IF lo < j THEN CALL quicksort(lo, j)
  IF i < hi THEN CALL quicksort(i, hi)
END SUB

SUB Rotate
'procedure Rotate;
xst = 2
yst = 0
zst = -2

'var
DIM xp(0 TO 7) AS INTEGER
DIM yp(0 TO 7) AS INTEGER
DIM z(0 TO 7) AS INTEGER
'  x,y,i,j,k:integer;
'  n,Key,phix,phiy,phiz:byte;

  phix = 0: phiy = 0: phiz = 0
'  fillchar(xp,sizeof(xp),0);
'  fillchar(yp,sizeof(yp),0);
SCREEN 7, 0, 0, 1
  DO
    'while (port[$3da] and 8) <> 8 do;
    'while (port($3da) and 8) = 8 do;
    'WAIT &H3DA, 8
    WAIT &H3DA, 8
    'CALL setpal(0, 0, 0, 50)

    FOR n = 3 TO 5
      CALL polygon(xp(planes(planez(n) AND 7, 0)), yp(planes(planez(n) AND 7, 0)), xp(planes(planez(n) AND 7, 1)), yp(planes(planez(n) AND 7, 1)), xp(planes(planez(n) AND 7, 2)), yp(planes(planez(n) AND 7, 2)), xp(planes(planez(n) AND 7, 3)), yp( _
planes(planez(n) AND 7, 3)), 0)
    NEXT n
    FOR n = 0 TO 7
      i = (cosinus(phiy) * points(n, 0) - sinus(phiy) * points(n, 2)) / 128
      j = (cosinus(phiz) * points(n, 1) - sinus(phiz) * i) / 128
      k = (cosinus(phiy) * points(n, 2) + sinus(phiy) * points(n, 0)) / 128
      x = (cosinus(phiz) * i + sinus(phiz) * points(n, 1)) / 128
      Y = (cosinus(phix) * j + sinus(phix) * k) / 128
      z(n) = (cosinus(phix) * k - sinus(phix) * j) / 128
      xp(n) = 160 + (-x * dist) / (z(n) - dist)
      yp(n) = 100 + (-Y * dist) / (z(n) - dist)
    NEXT n

    FOR n = 0 TO 5
      planez(n) = LShift%(INT(z(planes(n, 0)) + z(planes(n, 1)) + z(planes(n, 2)) + z(planes(n, 3))) / 4, 3 + n)
    NEXT n
    CALL quicksort(0, 5)

    FOR n = 3 TO 5
      CALL polygon(xp(planes(planez(n) AND 7, 0)), yp(planes(planez(n) AND 7, 0)), xp(planes(planez(n) AND 7, 1)), yp(planes(planez(n) AND 7, 1)), xp(planes(planez(n) AND 7, 2)), yp(planes(planez(n) AND 7, 2)), xp(planes(planez(n) AND 7, 3)), yp( _
planes(planez(n) AND 7, 3)), (planez(n) AND 7) + 1)
    NEXT n
    phix = phix + xst: phiy = phiy + yst: phiz = phiz + zst
    'CALL setpal(0, 0, 0, 0)
    PCOPY 0, 1
    'flip(virseg,vidseg);
  LOOP UNTIL INKEY$ <> ""
END SUB

SUB setpal (c, R, G, B) ' Remember this?
''''''''''''''''''''''''''''''''''''''''''''
''procedure setpal(c,r,g,b:byte); assembler;
''asm
''  mov dx,3c8h
''  mov al,[c]
''  out dx,al
''''''''''''''''''''''''''''''''''''''''''''
  OUT &H3C8, c
''''''''''''''''''''''''''
''  inc dx
'   &H3C8 + 1 = &H3C9
''  mov al,[r]
''  out dx,al
''''''''''''''''''''''''''
  OUT &H3C9, R
''''''''''''''''''
''  mov al,[g]
''  out dx,al
''''''''''''''''''
  OUT &H3C9, G
'''''''''''''''''''
''  mov al,[b]
''  out dx,al
'''''''''''''''''''
  OUT &H3C9, B
''end;
END SUB

FUNCTION sinus% (i)
  IF ABS(i) > 255 THEN i = 0
  sinus% = SinTab(ABS(i))
END FUNCTION