home *** CD-ROM | disk | FTP | other *** search
/ CD-X 1 / cdx_01.iso / demodisc / tyrant / vector / vector2.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1994-08-14  |  13.2 KB  |  433 lines
  1.  
  2. {$X+}
  3. USES Crt;
  4.  
  5. CONST VGA = $A000;
  6.       MaxLines = 12;
  7.       Obj : Array [1..MaxLines,1..2,1..3] of integer =
  8.         (
  9.         ((-10,-10,-10),(10,-10,-10)),((-10,-10,-10),(-10,10,-10)),
  10.         ((-10,10,-10),(10,10,-10)),((10,-10,-10),(10,10,-10)),
  11.         ((-10,-10,10),(10,-10,10)),((-10,-10,10),(-10,10,10)),
  12.         ((-10,10,10),(10,10,10)),((10,-10,10),(10,10,10)),
  13.         ((-10,-10,10),(-10,-10,-10)),((-10,10,10),(-10,10,-10)),
  14.         ((10,10,10),(10,10,-10)),((10,-10,10),(10,-10,-10))
  15.         );  { The 3-D coordinates of our object ... stored as (X1,Y1,Z1), }
  16.             { (X2,Y2,Z2) ... for the two ends of a line }
  17.  
  18.  
  19. Type Point = Record
  20.                x,y,z:real;                { The data on every point we rotate}
  21.              END;
  22.      Virtual = Array [1..64000] of byte;  { The size of our Virtual Screen }
  23.      VirtPtr = ^Virtual;                  { Pointer to the virtual screen }
  24.  
  25.  
  26. VAR Lines : Array [1..MaxLines,1..2] of Point;  { The base object rotated }
  27.     Translated : Array [1..MaxLines,1..2] of Point; { The rotated object }
  28.     Xoff,Yoff,Zoff:Integer;               { Used for movement of the object }
  29.     lookup : Array [0..360,1..2] of real; { Our sin and cos lookup table }
  30.     Virscr : VirtPtr;                     { Our first Virtual screen }
  31.     Vaddr  : word;                        { The segment of our virtual screen}
  32.  
  33.  
  34. {──────────────────────────────────────────────────────────────────────────}
  35. Procedure SetMCGA;  { This procedure gets you into 320x200x256 mode. }
  36. BEGIN
  37.   asm
  38.      mov        ax,0013h
  39.      int        10h
  40.   end;
  41. END;
  42.  
  43.  
  44. {──────────────────────────────────────────────────────────────────────────}
  45. Procedure SetText;  { This procedure returns you to text mode.  }
  46. BEGIN
  47.   asm
  48.      mov        ax,0003h
  49.      int        10h
  50.   end;
  51. END;
  52.  
  53. {──────────────────────────────────────────────────────────────────────────}
  54. Procedure Cls (Where:word;Col : Byte);
  55.    { This clears the screen to the specified color }
  56. BEGIN
  57.      asm
  58.         push    es
  59.         mov     cx, 32000;
  60.         mov     es,[where]
  61.         xor     di,di
  62.         mov     al,[col]
  63.         mov     ah,al
  64.         rep     stosw
  65.         pop     es
  66.      End;
  67. END;
  68.  
  69. {──────────────────────────────────────────────────────────────────────────}
  70. Procedure SetUpVirtual;
  71.    { This sets up the memory needed for the virtual screen }
  72. BEGIN
  73.   GetMem (VirScr,64000);
  74.   vaddr := seg (virscr^);
  75. END;
  76.  
  77.  
  78. {──────────────────────────────────────────────────────────────────────────}
  79. Procedure ShutDown;
  80.    { This frees the memory used by the virtual screen }
  81. BEGIN
  82.   FreeMem (VirScr,64000);
  83. END;
  84.  
  85.  
  86. {──────────────────────────────────────────────────────────────────────────}
  87. procedure flip(source,dest:Word);
  88.   { This copies the entire screen at "source" to destination }
  89. begin
  90.   asm
  91.     push    ds
  92.     mov     ax, [Dest]
  93.     mov     es, ax
  94.     mov     ax, [Source]
  95.     mov     ds, ax
  96.     xor     si, si
  97.     xor     di, di
  98.     mov     cx, 32000
  99.     rep     movsw
  100.     pop     ds
  101.   end;
  102. end;
  103.  
  104.  
  105. {──────────────────────────────────────────────────────────────────────────}
  106. Procedure Pal(Col,R,G,B : Byte);
  107.   { This sets the Red, Green and Blue values of a certain color }
  108. Begin
  109.    asm
  110.       mov    dx,3c8h
  111.       mov    al,[col]
  112.       out    dx,al
  113.       inc    dx
  114.       mov    al,[r]
  115.       out    dx,al
  116.       mov    al,[g]
  117.       out    dx,al
  118.       mov    al,[b]
  119.       out    dx,al
  120.    end;
  121. End;
  122.  
  123.  
  124. {──────────────────────────────────────────────────────────────────────────}
  125. Function rad (theta : real) : real;
  126.   {  This calculates the degrees of an angle }
  127. BEGIN
  128.   rad := theta * pi / 180
  129. END;
  130.  
  131.  
  132. {──────────────────────────────────────────────────────────────────────────}
  133. Procedure SetUpPoints;
  134.   { This sets the basic offsets of the object, creates the lookup table and
  135.     moves the object from a constant to a variable }
  136. VAR loop1:integer;
  137. BEGIN
  138.   Xoff:=160;
  139.   Yoff:=100;
  140.   Zoff:=-256;
  141.   For loop1:=0 to 360 do BEGIN
  142.     lookup [loop1,1]:=sin (rad (loop1));
  143.     lookup [loop1,2]:=cos (rad (loop1));
  144.   END;
  145.   For loop1:=1 to MaxLines do BEGIN
  146.     Lines [loop1,1].x:=Obj [loop1,1,1];
  147.     Lines [loop1,1].y:=Obj [loop1,1,2];
  148.     Lines [loop1,1].z:=Obj [loop1,1,3];
  149.     Lines [loop1,2].x:=Obj [loop1,2,1];
  150.     Lines [loop1,2].y:=Obj [loop1,2,2];
  151.     Lines [loop1,2].z:=Obj [loop1,2,3];
  152.   END;
  153. END;
  154.  
  155.  
  156. {──────────────────────────────────────────────────────────────────────────}
  157. Procedure Putpixel (X,Y : Integer; Col : Byte; where:word);
  158.   { This puts a pixel on the screen by writing directly to memory. }
  159. BEGIN
  160.   Asm
  161.     mov     ax,[where]
  162.     mov     es,ax
  163.     mov     bx,[X]
  164.     mov     dx,[Y]
  165.     mov     di,bx
  166.     mov     bx, dx                  {; bx = dx}
  167.     shl     dx, 8
  168.     shl     bx, 6
  169.     add     dx, bx                  {; dx = dx + bx (ie y*320)}
  170.     add     di, dx                  {; finalise location}
  171.     mov     al, [Col]
  172.     stosb
  173.   End;
  174. END;
  175.  
  176.  
  177.  
  178. {──────────────────────────────────────────────────────────────────────────}
  179. Procedure Line(a,b,c,d:integer;col:byte;where:word);
  180.   { This draws a solid line from a,b to c,d in colour col }
  181.   function sgn(a:real):integer;
  182.   begin
  183.        if a>0 then sgn:=+1;
  184.        if a<0 then sgn:=-1;
  185.        if a=0 then sgn:=0;
  186.   end;
  187. var i,s,d1x,d1y,d2x,d2y,u,v,m,n:integer;
  188. begin
  189.      u:= c - a;
  190.      v:= d - b;
  191.      d1x:= SGN(u);
  192.      d1y:= SGN(v);
  193.      d2x:= SGN(u);
  194.      d2y:= 0;
  195.      m:= ABS(u);
  196.      n := ABS(v);
  197.      IF NOT (M>N) then
  198.      BEGIN
  199.           d2x := 0 ;
  200.           d2y := SGN(v);
  201.           m := ABS(v);
  202.           n := ABS(u);
  203.      END;
  204.      s := m shr 1;
  205.      FOR i := 0 TO m DO
  206.      BEGIN
  207.           putpixel(a,b,col,where);
  208.           s := s + n;
  209.           IF not (s<m) THEN
  210.           BEGIN
  211.                s := s - m;
  212.                a:= a + d1x;
  213.                b := b + d1y;
  214.           END
  215.           ELSE
  216.           BEGIN
  217.                a := a + d2x;
  218.                b := b + d2y;
  219.           END;
  220.      end;
  221. END;
  222.  
  223.  
  224. {──────────────────────────────────────────────────────────────────────────}
  225. Procedure DrawLogo;
  226.   { This draws 'ASPHYXIA' at the top of the screen in little balls }
  227. CONST ball : Array [1..5,1..5] of byte =
  228.          ((0,1,1,1,0),
  229.           (1,4,3,2,1),
  230.           (1,3,3,2,1),
  231.           (1,2,2,2,1),
  232.           (0,1,1,1,0));
  233.  
  234. VAR Logo : Array [1..5] of String;
  235.     loop1,loop2,loop3,loop4:integer;
  236. BEGIN
  237.   pal (13,0,63,0);
  238.   pal (1,0,0,40);
  239.   pal (2,0,0,45);
  240.   pal (3,0,0,50);
  241.   pal (4,0,0,60);
  242.   Logo[1]:=' O  OOO OOO O O O O O O OOO  O ';
  243.   Logo[2]:='O O O   O O O O O O O O  O  O O';
  244.   Logo[3]:='OOO OOO OOO OOO  O   O   O  OOO';
  245.   Logo[4]:='O O   O O   O O  O  O O  O  O O';
  246.   Logo[5]:='O O OOO O   O O  O  O O OOO O O';
  247.   For loop1:=1 to 5 do
  248.     For loop2:=1 to 31 do
  249.       if logo[loop1][loop2]='O' then
  250.         For loop3:=1 to 5 do
  251.           For loop4:=1 to 5 do
  252.             putpixel (loop2*10+loop3,loop1*4+loop4,ball[loop3,loop4],vaddr);
  253. END;
  254.  
  255.  
  256.  
  257. {──────────────────────────────────────────────────────────────────────────}
  258. Procedure RotatePoints (X,Y,Z:Integer);
  259.   { This rotates object lines by X,Y and Z; then places the result in
  260.     TRANSLATED }
  261. VAR loop1:integer;
  262.     temp:point;
  263. BEGIN
  264.   For loop1:=1 to maxlines do BEGIN
  265.     temp.x:=lines[loop1,1].x;
  266.     temp.y:=lookup[x,2]*lines[loop1,1].y - lookup[x,1]*lines[loop1,1].z;
  267.     temp.z:=lookup[x,1]*lines[loop1,1].y + lookup[x,2]*lines[loop1,1].z;
  268.  
  269.     translated[loop1,1]:=temp;
  270.  
  271.     If y>0 then BEGIN
  272.       temp.x:=lookup[y,2]*translated[loop1,1].x - lookup[y,1]*translated[loop1,1].y;
  273.       temp.y:=lookup[y,1]*translated[loop1,1].x + lookup[y,2]*translated[loop1,1].y;
  274.       temp.z:=translated[loop1,1].z;
  275.       translated[loop1,1]:=temp;
  276.     END;
  277.  
  278.     If z>0 then BEGIN
  279.       temp.x:=lookup[z,2]*translated[loop1,1].x + lookup[z,1]*translated[loop1,1].z;
  280.       temp.y:=translated[loop1,1].y;
  281.       temp.z:=-lookup[z,1]*translated[loop1,1].x + lookup[z,2]*translated[loop1,1].z;
  282.       translated[loop1,1]:=temp;
  283.     END;
  284.  
  285.     temp.x:=lines[loop1,2].x;
  286.     temp.y:=cos (rad(X))*lines[loop1,2].y - sin (rad(X))*lines[loop1,2].z;
  287.     temp.z:=sin (rad(X))*lines[loop1,2].y + cos (rad(X))*lines[loop1,2].z;
  288.  
  289.     translated[loop1,2]:=temp;
  290.  
  291.     If y>0 then BEGIN
  292.       temp.x:=cos (rad(Y))*translated[loop1,2].x - sin (rad(Y))*translated[loop1,2].y;
  293.       temp.y:=sin (rad(Y))*translated[loop1,2].x + cos (rad(Y))*translated[loop1,2].y;
  294.       temp.z:=translated[loop1,2].z;
  295.       translated[loop1,2]:=temp;
  296.     END;
  297.  
  298.     If z>0 then BEGIN
  299.       temp.x:=cos (rad(Z))*translated[loop1,2].x + sin (rad(Z))*translated[loop1,2].z;
  300.       temp.y:=translated[loop1,2].y;
  301.       temp.z:=-sin (rad(Z))*translated[loop1,2].x + cos (rad(Z))*translated[loop1,2].z;
  302.       translated[loop1,2]:=temp;
  303.     END;
  304.   END;
  305. END;
  306.  
  307.  
  308.  
  309. {──────────────────────────────────────────────────────────────────────────}
  310. Procedure DrawPoints;
  311.   { This draws the translated object to the virtual screen }
  312. VAR loop1:Integer;
  313.     nx,ny,nx2,ny2:integer;
  314.     temp:integer;
  315. BEGIN
  316.   For loop1:=1 to MaxLines do BEGIN
  317.     If (translated[loop1,1].z+zoff<0) and (translated[loop1,2].z+zoff<0) then BEGIN
  318.       temp:=round (translated[loop1,1].z+zoff);
  319.       nx :=round (256*translated[loop1,1].X) div temp+xoff;
  320.       ny :=round (256*translated[loop1,1].Y) div temp+yoff;
  321.       temp:=round (translated[loop1,2].z+zoff);
  322.       nx2:=round (256*translated[loop1,2].X) div temp+xoff;
  323.       ny2:=round (256*translated[loop1,2].Y) div temp+yoff;
  324.       If (NX > 0) and (NX < 320) and (NY > 25) and (NY < 200) and
  325.          (NX2> 0) and (NX2< 320) and (NY2> 25) and (NY2< 200) then
  326.            line (nx,ny,nx2,ny2,13,vaddr);
  327.     END;
  328.   END;
  329. END;
  330.  
  331. {──────────────────────────────────────────────────────────────────────────}
  332. Procedure ClearPoints;
  333.   { This clears the translated object from the virtual screen ... believe it
  334.     or not, this is faster then a straight "cls (vaddr,0)" }
  335. VAR loop1:Integer;
  336.     nx,ny,nx2,ny2:Integer;
  337.     temp:integer;
  338. BEGIN
  339.   For loop1:=1 to MaxLines do BEGIN
  340.     If (translated[loop1,1].z+zoff<0) and (translated[loop1,2].z+zoff<0) then BEGIN
  341.       temp:=round (translated[loop1,1].z+zoff);
  342.       nx :=round (256*translated[loop1,1].X) div temp+xoff;
  343.       ny :=round (256*translated[loop1,1].Y) div temp+yoff;
  344.       temp:=round (translated[loop1,2].z+zoff);
  345.       nx2:=round (256*translated[loop1,2].X) div temp+xoff;
  346.       ny2:=round (256*translated[loop1,2].Y) div temp+yoff;
  347.       If (NX > 0) and (NX < 320) and (NY > 25) and (NY < 200) and
  348.          (NX2> 0) and (NX2< 320) and (NY2> 25) and (NY2< 200) then
  349.            line (nx,ny,nx2,ny2,0,vaddr);
  350.     END;
  351.   END;
  352. END;
  353.  
  354.  
  355. {──────────────────────────────────────────────────────────────────────────}
  356. Procedure MoveAround;
  357.   { This is the main display procedure. Firstly it brings the object towards
  358.     the viewer by increasing the Zoff, then passes control to the user }
  359. VAR deg,loop1:integer;
  360.     ch:char;
  361. BEGIN
  362.   deg:=0;
  363.   ch:=#0;
  364.   Cls (vaddr,0);
  365.   DrawLogo;
  366.   For loop1:=-256 to -40 do BEGIN
  367.     zoff:=loop1*2;
  368.     RotatePoints (deg,deg,deg);
  369.     DrawPoints;
  370.     flip (vaddr,vga);
  371.     ClearPoints;
  372.     deg:=(deg+5) mod 360;
  373.   END;
  374.  
  375.   Repeat
  376.     if keypressed then BEGIN
  377.       ch:=upcase (Readkey);
  378.       Case ch of 'A' : zoff:=zoff+5;
  379.                  'Z' : zoff:=zoff-5;
  380.                  ',' : xoff:=xoff-5;
  381.                  '.' : xoff:=xoff+5;
  382.                  'S' : yoff:=yoff-5;
  383.                  'X' : yoff:=yoff+5;
  384.       END;
  385.     END;
  386.     DrawPoints;
  387.     flip (vaddr,vga);
  388.     ClearPoints;
  389.     RotatePoints (deg,deg,deg);
  390.     deg:=(deg+5) mod 360;
  391.   Until ch=#27;
  392. END;
  393.  
  394.  
  395. BEGIN
  396.   SetUpVirtual;
  397.   Writeln ('Greetings and salutations! Hope you had a great Christmas and New');
  398.   Writeln ('year! ;-) ... Anyway, this tutorial is on 3-D, so this is what is');
  399.   Writeln ('going to happen ... a wireframe square will come towards you.');
  400.   Writeln ('When it gets close, you get control. "A" and "Z" control the Z');
  401.   Writeln ('movement, "," and "." control the X movement, and "S" and "X"');
  402.   Writeln ('control the Y movement. I have not included rotation control, but');
  403.   Writeln ('it should be easy enough to put in yourself ... if you have any');
  404.   Writeln ('hassles, leave me mail.');
  405.   Writeln;
  406.   Writeln ('Read the main text file for ideas on improving this code ... and');
  407.   Writeln ('welcome to the world of 3-D!');
  408.   writeln;
  409.   writeln;
  410.   Write ('  Hit any key to contine ...');
  411.   Readkey;
  412.   SetMCGA;
  413.   SetUpPoints;
  414.   MoveAround;
  415.   SetText;
  416.   ShutDown;
  417.   Writeln ('All done. This concludes the eigth sample program in the ASPHYXIA');
  418.   Writeln ('Training series. You may reach DENTHOR under the names of GRANT');
  419.   Writeln ('SMITH/DENTHOR/ASPHYXIA on the ASPHYXIA BBS. I am also an avid');
  420.   Writeln ('Connectix BBS user, and occasionally read RSAProg.');
  421.   Writeln ('For discussion purposes, I am also the moderator of the Programming');
  422.   Writeln ('newsgroup on the For Your Eyes Only BBS.');
  423.   Writeln ('The numbers are available in the main text. You may also write to me at:');
  424.   Writeln ('             Grant Smith');
  425.   Writeln ('             P.O. Box 270');
  426.   Writeln ('             Kloof');
  427.   Writeln ('             3640');
  428.   Writeln ('I hope to hear from you soon!');
  429.   Writeln; Writeln;
  430.   Write   ('Hit any key to exit ...');
  431.   Readkey;
  432. END.
  433.