home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / gfxfx / rot3.pas < prev    next >
Pascal/Delphi Source File  |  1994-06-22  |  6KB  |  202 lines
  1.  
  2. program _Rotation;
  3. { Rotating cube, line-routine by Winston van Oosterhout, rest
  4.   by Bas van Gaalen, Holland, PD, try cursor up/down }
  5. uses
  6.   crt;
  7.  
  8. const
  9.   ScrBase : word = $a000;
  10.   Xc = 0;
  11.   Yc = 0;
  12.   Zc = 150;
  13.   Point : array[0..7,0..2] of integer = (
  14.     (-25,25,25),(25,25,25),(25,-25,25),(-25,-25,25),
  15.     (-25,25,-25),(25,25,-25),(25,-25,-25),(-25,-25,-25));
  16.   Lines : array[0..11,0..1] of byte = (
  17.     (0,1),(1,2),(2,3),(3,0),(0,4),(1,5),(2,6),(3,7),(4,5),(5,6),(6,7),(7,4));
  18.  
  19. type
  20.   TabType = array[0..255] of integer;
  21.  
  22. var
  23.   SinTab : TabType;
  24.   Color : byte;
  25.  
  26. {----------------------------------------------------------------------------}
  27.  
  28. procedure SetGraphics(Mode : byte); assembler; asm
  29.   mov AH,0; mov AL,Mode; int 10h; end;
  30.  
  31. {----------------------------------------------------------------------------}
  32.  
  33. procedure Calcsinus(var SinTab : TabType); var I : byte; begin
  34.   for I := 0 to 255 do SinTab[I] := round(sin(2*I*pi/255)*128); end;
  35.  
  36. {----------------------------------------------------------------------------}
  37.  
  38. function Sinus(Idx : byte) : integer; begin
  39.   Sinus := SinTab[Idx]; end;
  40.  
  41. {----------------------------------------------------------------------------}
  42.  
  43. function Cosinus(Idx : byte) : integer; begin
  44.   Cosinus := SinTab[(Idx+192) mod 255]; end;
  45.  
  46. {----------------------------------------------------------------------------}
  47.  
  48. procedure Line(X1,Y1,X2,Y2 : integer); assembler;
  49.  
  50. const XInc : integer = 1; OffS : word = $140;
  51. var Incr2 : integer;
  52.  
  53. asm
  54.   mov ax,Y1; mov cx,Y2; sub cx,ax; je @Hline;
  55.   mov bx,X2; mov dx,X1; sub bx,dx; je @VLine;
  56.   sub ax,Y2; cwd; xor ax,dx; sub ax,dx; mov si,dx; mov cx,ax
  57.   mov ax,X1; sub ax,X2; cwd; xor ax,dx; sub ax,dx; cmp ax,cx
  58.   jl @YLine; jmp @XLine
  59.  @HLine:
  60.   mov es,ScrBase; mov dx,X1; mov cx,X2; cmp dx,cx; jle @HContinue; xchg dx,cx
  61.  @HContinue:
  62.   sub cx,dx; mov di,dx; xchg ah,al; add di,ax; shr ax,1; shr ax,1
  63.   add di,ax; inc cx; mov al,Color; rep stosb; jmp @Exit
  64.  @VLine:
  65.   mov es,ScrBase; cmp cx,0; jg @VContinue; neg cx; mov ax,Y2
  66.  @VContinue:
  67.   inc cx; mov di,dx; xchg ah,al; add di,ax; shr ax,1
  68.   shr ax,1; add di,ax; mov al,Color
  69.  @VRunLoop:
  70.   mov es:[di],al; add di,140h; loop @VRunLoop; jmp @Exit
  71.  @YLine:
  72.   mov es,ax; sub ax,cx; shl ax,1; mov sp,ax; mov XInc,1; mov ax,es
  73.   shl ax,1; mov bx,ax; sub bx,cx; cmp si,-1; je @Y2greaterY1
  74.  @Y1greaterY2:
  75.   mov si,ax; mov ax,X2; cmp dx,-1; mov dx,Y2; je @YNeg; jmp @YContinue
  76.  @Y2greaterY1:
  77.   mov si,ax; mov ax,X1; cmp dx,0; mov dx,Y1; je @YNeg; jmp @YContinue
  78.  @YNeg:
  79.   neg XInc
  80.  @YContinue:
  81.   mov di,ax; xchg dh,dl; add di,dx; shr dx,1; shr dx,1
  82.   add di,dx; mov ah,Color; mov es,ScrBase; inc cx
  83.  @YRunLoop:
  84.   mov es:[di],ah; add di,140h; cmp bx,0; jl @YNoInc; add bx,sp
  85.   add di,XInc; jmp @YCheck
  86.  @YNoInc:
  87.   add bx,si
  88.  @YCheck:
  89.   loop @YRunLoop; jmp @Exit
  90.  @XLine:
  91.   cmp dx,-1; jle @X2greaterX1
  92.   mov bx,X2; mov dx,Y2; cmp si,-1; mov si,140h; je @XNeg; jmp @XContinue
  93.  @X2greaterX1:
  94.   mov bx,X1; mov dx,Y1; cmp si,-1; mov si,140h; jne @XNeg; jmp @XContinue
  95.  @XNeg:
  96.   neg si
  97.  @XContinue:
  98.   mov di,bx; xchg dh,dl; add di,dx; shr dx,1; shr dx,1; add di,dx
  99.   mov sp,cx; sub sp,ax; shl sp,1; mov bx,cx; shl bx,1; mov OffS,si
  100.   mov si,bx; sub bx,ax; mov cx,ax; mov es,ScrBase; mov ah,Color; inc cx
  101.  @XRunLoop:
  102.   mov es:[di],ah; inc di; cmp bx,0; jl @XNoInc; add bx,sp; add di,OffS; jmp @XCheck
  103.  @XNoInc:
  104.   add bx,si
  105.  @XCheck:
  106.   loop @XRunLoop
  107.  @Exit:
  108. end;
  109.  
  110. {----------------------------------------------------------------------------}
  111.  
  112. procedure pal(colour,r,g,b : byte); assembler;
  113. { This sets the Red, Green and Blue values of a certain color }
  114. asm
  115.   mov dx,3c8h
  116.   mov al,[colour]
  117.   out dx,al
  118.   inc dx
  119.   mov al,[r]
  120.   out dx,al
  121.   mov al,[g]
  122.   out dx,al
  123.   mov al,[b]
  124.   out dx,al
  125. end;
  126.  
  127. procedure Rotate;
  128.  
  129. const
  130.   Xstep = 1;
  131.   Ystep = 1;
  132.   Zstep = -1;
  133.  
  134. var
  135.   Xp,Yp : array[0..7] of word;
  136.   X,Y,Z,X1,Y1,Z1 : integer;
  137.   I,Key,PhiX,PhiY,PhiZ : byte;
  138.  
  139. begin
  140.   PhiX := 0; PhiY := 0; PhiZ := 0;
  141.   for I := 0 to 7 do begin Xp[I] := 0; Yp[I] := 0; end;
  142.   repeat
  143.     while (port[$3da] and 8) <> 8 do;
  144.     while (port[$3da] and 8) = 8 do;
  145.  
  146.     pal(0,0,0,50);
  147.  
  148.     Color := 0;
  149.     for I := 0 to 11 do
  150.       Line(Xp[Lines[I,0]],Yp[Lines[I,0]],Xp[Lines[I,1]],Yp[Lines[I,1]]);
  151.  
  152.     for I := 0 to 7 do begin
  153.       X1 := (Cosinus(PhiY)*Point[I,0]-Sinus(PhiY)*Point[I,2]) div 128;
  154.       Y1 := (Cosinus(PhiZ)*Point[I,1]-Sinus(PhiZ)*X1) div 128;
  155.       Z1 := (Cosinus(PhiY)*Point[I,2]+Sinus(PhiY)*Point[I,0]) div 128;
  156.       X := (Cosinus(PhiZ)*X1+Sinus(PhiZ)*Point[I,1]) div 128;
  157.       Y := (Cosinus(PhiX)*Y1+Sinus(PhiX)*z1) div 128;
  158.       Z := (Cosinus(PhiX)*Z1-Sinus(PhiX)*Y1) div 128;
  159.       Xp[I] := 160+(Xc*Z-X*Zc) div (Z-Zc);
  160.       Yp[I] := 100+(Yc*Z-Y*Zc) div (Z-Zc);
  161.     end;
  162.  
  163.     Color := 7;
  164.     for I := 0 to 11 do
  165.       Line(Xp[Lines[I,0]],Yp[Lines[I,0]],Xp[Lines[I,1]],Yp[Lines[I,1]]);
  166.  
  167.     inc(PhiX,Xstep);
  168.     inc(PhiY,Ystep);
  169.     inc(PhiZ,Zstep);
  170.  
  171.     pal(0,0,0,0);
  172.  
  173.     if keypressed then begin
  174.       Key := ord(readkey);
  175.       if Key = 0 then begin
  176.         Key := ord(readkey);
  177.         case Key of
  178.           72 : if Point[1,0] < 40 then for I := 0 to 7 do begin
  179.                  Point[I,0] := round(Point[I,0]*1.1);
  180.                  Point[I,1] := round(Point[I,1]*1.1);
  181.                  Point[I,2] := round(Point[I,2]*1.1);
  182.                end; { Up }
  183.           80 : if Point[1,0] > 5 then for I := 0 to 7 do begin
  184.                  Point[I,0] := round(Point[I,0]*0.9);
  185.                  Point[I,1] := round(Point[I,1]*0.9);
  186.                  Point[I,2] := round(Point[I,2]*0.9);
  187.                end; { Down }
  188.         end;
  189.       end;
  190.     end;
  191.   until Key = 27;
  192. end;
  193.  
  194. {----------------------------------------------------------------------------}
  195.  
  196. begin
  197.   Calcsinus(SinTab);
  198.   SetGraphics($13);
  199.   Rotate;
  200.   textmode(lastmode);
  201. end.
  202.