home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / pasgraph / vector.pas < prev    next >
Pascal/Delphi Source File  |  1994-02-10  |  21KB  |  753 lines
  1. {  Vectorspaceship by Captain Headcrash
  2.    be careful this program is verry
  3.    dirty and not optimized but gives you
  4.    an image of the power of TP
  5.  
  6.    Some of the code is ripped from various sources
  7.    if you want to contact me, then write to:
  8.    Dirk Hoeschen
  9.    Fido:   2:245/114.1 or 2:2445/110.1
  10.    Gernet: 21:100/2202 Gamenet: 144:4915/35}
  11.  
  12. {$N+,G+}
  13. Program VectorShip;
  14.  
  15. Uses
  16.   Crt,
  17.   Dos;
  18.  
  19. Type
  20.   LineY   = Array[0..199] Of Word;
  21.   TabType = array[0..255] Of shortint;
  22.  
  23. Const
  24.   Xc  = 0;
  25.   Yc  = 0;
  26.   Zc  = 300;
  27.   NofPoints = 16;
  28.   Nofpolys  =  7;
  29.   Speed     : Integer = -3;
  30.   PhiX      : Byte    = 0;
  31.   Phiy      : Byte    = 0;
  32.   Phiz      : Byte    = 0;
  33.   WOff      : Word    = 0;
  34.   ScrOff    : Word    = 0;
  35.   Size      : Integer = 100;
  36.   Point     : Array[0..NofPoints,0..2] Of Integer =
  37.               (( 50 ,   0 , 0),  {front}
  38.                (-50 ,  40 , 0),  {upper corner}
  39.                (-50 , -40 , 0),  {lower Corner}
  40.                (-60 ,   0 ,20),  {tail top}
  41.                (-60 ,   0 ,-20), {tail down}
  42.                ( 20 ,  41 , 0),
  43.                (-60 ,  41 , 10),
  44.                (-60 ,  41 ,-10),
  45.                ( 20 , -41 , 0),
  46.                (-60 , -41 , 10),
  47.                (-60 , -41 ,-10),
  48.                ( 30 ,  2 , 2),
  49.                (-30 ,  2 ,14),
  50.                (-20 , 20 , 2),
  51.                ( 30 , -2,  3),
  52.                (-30 , -2, 14),
  53.                (-20 ,-20,  3));
  54.  
  55.   Polyst    : Array[0..Nofpolys+2,0..2] Of Byte = (
  56.               (0,1,3),(0,2,3),  (0,1,4), (0,2,4),
  57.               (1,3,4), (2,3,4), (5,6,7), (8,9,10),
  58.               (11,12,13),(14,15,16));
  59.   Polcols   : Array[0..Nofpolys+2] Of Byte =
  60.               (16,17,18,19,20,21,22,23,24,25);
  61.   Colors    : Array[0..Nofpolys+2,0..2] Of Byte =(
  62.               ( 55 ,  15 , 40), {upper tail r}
  63.               ( 50 ,  10 , 35), {upper tail l}
  64.               ( 15 ,  45 , 35), {lower tail r}
  65.               ( 10 ,  40 , 30), {lower tail l}
  66.               ( 55 ,  10 ,  0), {motor r}
  67.               ( 55 ,  10 ,  0), {motor l}
  68.               ( 40 ,  50 , 50), {wing r}
  69.               ( 40 ,  50 , 50), {wing l}
  70.               ( 15 ,  35 , 55), {window r}
  71.               ( 10 ,  30 , 50));{window l}
  72.   BgndCols  : Array[0..9,0..2] Of Byte = (
  73.               (40,50,63),(30,40,55),
  74.               (20,30,45),(10,20,35),
  75.               (10,15,30),(35,20, 0),
  76.               (45,25,10),(55,35,15),
  77.               (63,45,15),(63,55,20));
  78.   Mcol      : Byte = 0;
  79.   Mcol1     : Byte = 10;
  80.   Puls      : Byte = 5;
  81.   Puls1     : Byte = 5;
  82.  
  83. Var
  84.   PInd      : Array[0..Nofpolys] Of Integer;
  85.   Polyz     : Array[0..Nofpolys] Of Integer;
  86.   Wx,
  87.   lArray,
  88.   SArray    : Word;
  89.   I         : Integer;
  90.   Ch        : Char;
  91.   La        : ^LineY;
  92.   SinTab    : TabType;
  93.  
  94. {---------------Init demo-----------------------------}
  95.  
  96. Procedure SetColor(Color, r, g, b: Byte); Assembler;
  97.  
  98.   Asm {set DAC Color}
  99.     Mov  dx, 3C8h   {Color port}
  100.     Mov  al, Color  {number Of Color to change}
  101.     Out  dx, al
  102.     Inc  dx         {Inc dx to write}
  103.     Mov  al, r      {red value}
  104.     Out  dx, al
  105.     Mov  al, g      {green}
  106.     Out  dx, al
  107.     Mov  al, b      {blue}
  108.     Out  dx, al
  109.  
  110.   End; {Write index now points to next Color}
  111.  
  112. {-----------------------------------------------------}
  113.  
  114. Procedure Calcsinus(var SinTab : TabType);
  115.  
  116.   Var I : Byte;
  117.  
  118.   Begin
  119.     For I := 0 To 255 Do
  120.       SinTab[I] := round(sin(2*I*pi/255)*127);
  121.   End;
  122.  
  123. {---------------graphic stuff-------------------------}
  124.  
  125. Var
  126.   Color      : Byte;
  127.   CrtcPort   : Word;       {Crt controller}
  128.   OldMode    : Byte;
  129.   Input1Port : Word;       {Crtc Input Status Reg #1=CrtcPort+6}
  130.  
  131. Const
  132.   seqPort  = $3C4;         {Sequencer}
  133.   gcPort   = $3CE;         {Graphics Controller}
  134.   attrPort = $3C0;         {attribute Controller}
  135.   xRes     = 320;
  136.   yRes     = 200;          {displayed screen Size}
  137.   vxRes    = 640;          {Vitual xres For scrolling etc}
  138.   vSeg     = $A000;        {video segment}
  139.   vxBytes  = vxRes div 4;  {Bytes per virtual scan line}
  140.  
  141.  
  142. {-----------------------------------------------------}
  143.  
  144. Procedure GraphBegin; {Switch To 4frame mode}
  145.  
  146.   Var
  147.     I, J,
  148.     K, L  : Byte;
  149.  
  150.   Begin
  151.     CrtcPort   := MemW[$40 : $63];
  152.     Input1Port := CrtcPort + 6;
  153.     Asm
  154.       Mov   Ah, $000f
  155.       Int   $10
  156.       Mov   OldMode,al     {get old mode}
  157.       Mov   AX,0013h       {Use Bios To switch mode 13h }
  158.       Int   10h            {(=320x200x256)}
  159.       Mov   DX,SeqPort     {get sequencerport and}
  160.       Mov   AL,04h         {select memorymode-register}
  161.       Out   DX,AL          {and Do it}
  162.       Inc   DX             {Inc To readport}
  163.       In    AL,DX          {read memorymode}
  164.       And   AL,011110111b  {Bit 3:=0:4 planes Do not chaIn}
  165.       Or    AL,000000100b  {Bit 2:=1:no odd/even-mechan.}
  166.       Out   DX,AL          {write value}
  167.       Dec   DX             {back To sequenzer-register }
  168.       Mov   AX,0F02h       {(=Map-Mask) 11}
  169.       Out   DX,AX          {select..}
  170.                            {;...allow access To al 4 bitmaps}
  171.       Mov   AX,Vseg        {Segment $A000 allows direct acces}
  172.       Mov   ES,AX          {write To ES}
  173.       Xor   DI,DI          {DI=0 BegInIng Of the plane}
  174.       Xor   AX,AX          {AX=0 To clear screen}
  175.       Mov   CX,08000h      {8000h Words To clear vga-mem}
  176.       Cld                  {clear direction flag}
  177.       RepNZ SToSW          {write AX To ES:DI / Inc DI / Dec CX
  178.                             And repeat until CX=0}
  179.       Mov   DX,3D4h        {CRT-Controller}
  180.       Mov   AL,14h         {UnderlIne-location-Register}
  181.       Out   DX,AL          {activate}
  182.       Inc   DX             {Inc To DatapOrt}
  183.       In    AL,DX          {read DatapOrt}
  184.       And   AL,010111111b  {Bit 6:=0: no dubbleWord-}
  185.       Out   DX,AL          {adressIng}
  186.       Dec   DX
  187.       Mov   AL,017h        {Mode-control-register}
  188.       Out   DX,AL
  189.       Inc   DX
  190.       In    AL,DX
  191.       Or    AL,01000000b   {Bit 6:=1: To access the whole}
  192.       Out   DX,AL          {memOry lInear}
  193.       Mov   DX,3D4h        {CRT-Controller}
  194.       Mov   ax, vxBytes    {virtual xSize In Bytes}
  195.       Shr   ax, 1          {Words per scan lIne}
  196.       Mov   ah, al         {copy To hiByte}
  197.       Mov   al, $13        {13h ScreenSizeOffset reg}
  198.       Out   dx, ax         {set CrtC Offset reg}
  199.     End;
  200.   End;
  201.  
  202. {-----------------------------------------------------}
  203.  
  204. Procedure GraphEnd; Assembler;
  205.  
  206.   Asm
  207.     Mov al, OldMode
  208.     Mov ah, 0
  209.     Int $10
  210.   End;
  211.  
  212. {-----------------------------------------------------}
  213.  
  214. Procedure SetWindow(X, Y : Integer); Assembler;
  215.  
  216.   Asm
  217.     Mov  ax, vxBytes
  218.     Mul  y
  219.     Mov  bx, x
  220.     Mov  cl, bl
  221.     Shr  bx, 2
  222.     Add  bx, ax    {bx=Ofs Of upper left cOrner}
  223.     Mov  dx, Input1POrt
  224.    @L:
  225.     In   al, dx
  226.     Test al, 8
  227.     Jnz  @L        {wait For no v retrace}
  228.     Sub  dx, 6     {CrtC pOrt}
  229.     Mov  al, $D
  230.     Mov  ah, bl
  231.     Cli            {these values are sampled at start Of retrace}
  232.     Out  dx, ax    {lo Byte Of display start Addr}
  233.     Dec  al
  234.     Mov  ah, bh
  235.     Out  dx, ax    {hi Byte}
  236.     Sti
  237.     Add  dx, 6
  238.    @L2:
  239.     In   al, dx
  240.     Test al, 8
  241.     Jz   @L2       {wait For v retrace}
  242.                    {this also resets Attrib flip/flop}
  243.     Mov  dx, attrPOrt
  244.     Mov  al, $33
  245.     Out  dx, al    {Select Pixel Pan Register}
  246.     And  cl, 3
  247.     Mov  al, cl
  248.     Shl  al, 1
  249.     Out  dx, al    {Shift is For 256 ColOr Mode}
  250. End;
  251.  
  252. {-----------------------------------------------------}
  253.  
  254. Procedure WaitRetrace; Assembler;
  255.  
  256.   Asm
  257.     Mov  dx, CrtcPOrt
  258.     Add  dx, 6 {fInd Crt status reg (Input pOrt #1)}
  259.    @L1:
  260.     In   al, dx
  261.     Test al, 8
  262.     Jnz  @L1;  {wait For no v retrace}
  263.    @L2:
  264.     In   al, dx
  265.     Test al, 8
  266.     Jz   @L2 {wait For v retrace}
  267.   End;
  268.  
  269. {-----------------------------------------------------}
  270.  
  271. Procedure ClearScreen(ScrOff: Word);
  272.  
  273.   Const
  274.     Diffs     : Array[0..9] Of Word =
  275.                 ( 45,35,20,15,10,5,10,15,20,25);
  276.  
  277.   Var
  278.     DiffPoint : PoInter;
  279.  
  280.   Begin
  281.     DiffPoint := Addr(diffs);
  282.     Asm
  283.       Mov     DX,SeqPOrt
  284.       Mov     AX,00F02h     {activate all 4 frames}
  285.       Out     DX,AX
  286.       Mov     AX,Vseg       {a000h= Begin Of videopage}
  287.       Mov     ES,AX
  288.       Mov     DI,ScrOff     {Add Ofset To di}
  289.       Lds     si,DiffPoint  {poInts To an list with the Sizes
  290.                              Of the ColOrbars}
  291.       Mov     Ax,01E1Eh     {first BGNDColOr=30}
  292.       Mov     CX,10         {ten ColOrs at all}
  293.  
  294.      @NextColOr:
  295.  
  296.       Push    CX            {save cx}
  297.       Mov     CX,DS:[si]    {number Of lInes}
  298.       Add     SI,2          {Inc si}
  299.  
  300.      @NextLIne:
  301.  
  302.       Push    CX
  303.       Mov     CX,40         {Words per lIne / 4 }
  304.       Cld
  305.       Rep     Stosw         {fill lIne with ax}
  306.       Add     DI,VxBytes-80 {Add 80 bcause Of vxSize=640}
  307.       Pop     CX
  308.       Loop   @NextLIne
  309.       Inc     Al            {next ColOr}
  310.       Inc     Ah
  311.       Cld
  312.       Pop     CX
  313.       Loop   @NextColOr
  314.     End;
  315.   End;
  316.  
  317. {-----------------------------------------------------}
  318.  
  319. Procedure HLin(x, x2, y : Integer); Assembler;
  320.  
  321.   Asm
  322.     Mov   ax, vSeg     {A000 nach AX}
  323.     Mov   es, ax       {Adresssegment nach ES}
  324.     Cld                {Richtungsflag löschen}
  325.     Mov   ax, vxBytes  {Anzahl der Bytes In x-richtung}
  326.     Mul   y            {Multipliziert mit y}
  327.     Mov   di, ax       {base Of scan lIne}
  328.     Mov   bx, x        {X nach BX}
  329.     Mov   dx, x2       {X2 nach DX}
  330.     Sub   dx, bx       {Breite In Bytes x2-x}
  331.     Jns  @bigger       {ist x2 > X}
  332.     Mov   bx, x2       {X2 nach BX}
  333.     Mov   dx, x        {X  nach DX}
  334.     Jmp  @lower
  335.  
  336.    @bigger:
  337.  
  338.     Mov   dx, x2       {X2 nach DX}
  339.  
  340.    @lower:
  341.  
  342.     Mov   cl, bl       {veschieben nach lowByte CX}
  343.     Shr   bx, 2        {durch 4 teilen 1Punkt 4 Planes}
  344.     Mov   ch, dl       {verschieben nach hiByte cx}
  345.     Shr   dx, 2        {durch 4 teilen}
  346.     Sub   dx, bx       {Breite In Bytes x2-x}
  347.     And   cx, $0303    {Jeweils die ersten 2 Bit HI und low Ausmaskieren}
  348.     Add   di, bx       {ZeileNoffset auf DI}
  349.     Mov   ax, $FF02    {HiByte füllen lowByte bit 1 setzen}
  350.     Shl   ah, cl       {hiByte um anfangsOffset shiften}
  351.     And   ah, $0F      {lInken RAnd ausmaskieren}
  352.     Mov   cl, ch       {rechter Offset nach cl}
  353.     Mov   bh, $F1      {11110001 nach Bh}
  354.     Rol   bh, cl       {Rollen im HiByte um ch}
  355.     And   bh, $0F      {rechten rAnd ausmaskieren}
  356.     Mov   cx, dx       {breite In Bytes nach cx}
  357.     Or    cx, cx       {was soll das denn?}
  358.     Jnz  @LEFT         {achso Testen auf null}
  359.     And   ah, bh       {KombIniere lInke & rechte bitmaske}
  360.  
  361.    @Left:
  362.  
  363.     Mov   dx, seqPOrt  {AuswahlpOrt fuer die planes}
  364.     Out   dx, ax       {planes auswaehlen}
  365.     Inc   dx           {nach schreibpOrt erhoehen 3d5}
  366.     Mov   al, ColOr    {farbe nach al}
  367.     Stosb              {und lInken rAnd schreiben}
  368.     Jcxz @Exit         {wenn cx null ist dann abbrechen}
  369.     Dec   cx           {ansonsten Decrementieren}
  370.     Jcxz @RIGHT        {wenn null, dann rechte seite schreiben}
  371.     Mov   al, $0F      {00001111 alle planes auswaehlen}
  372.     Out   dx, al       {skipped if cx=0,1}
  373.     Mov   al, ColOr    {Farbe nach al}
  374.     Repz  Stosb        {mittlere Bytes schreiben jeweils 4 Punkte}
  375.  
  376.    @Right:
  377.  
  378.     Mov   al, bh       {rechte maske nach al}
  379.     Out   dx, al       {skipped if cx=0}
  380.     Mov   al, ColOr    {Farbe nach al}
  381.     Stosb              {rechte maske schreiben}
  382.  
  383.    @Exit:
  384.   End;
  385.  
  386. {------------------------------------------------------------}
  387.  
  388. Procedure DoFill;
  389.  
  390.   Const
  391.     Xstep   = -3;
  392.     Ystep   = 1;
  393.     Zstep   = -2;
  394.  
  395.   Var
  396.     s,pc, d        : Integer;
  397.     polyx,polyy    : Array[0..2] Of Word;
  398.     px,py,pz       : Array[0..NofPoInts] Of Word;
  399.     X,Y,Z,X1,Y1,Z1 : Integer;
  400.  
  401. {--------------------- FillRoutines -------------------------}
  402.  
  403. Procedure Fillpoly;
  404.  
  405.   {-----------------------------------------------------}
  406.  
  407.   Procedure Fline(x,y,x2,y2:Word);
  408.  
  409.     Var d,dx,dy,ai,bi,xi,yi:Integer;
  410.  
  411.     Begin
  412.       If(x<x2) Then
  413.         Begin
  414.           xi := 1;
  415.           dx := x2-x;
  416.         End
  417.       Else
  418.         Begin
  419.           xi := -1;
  420.           dx := x-x2;
  421.         End;
  422.       yi     := 1;
  423.       dy     := y2-y;
  424.       la^[y] :=x;      {whenever y changes write xvalue To la[y]}
  425.       If dx > dy Then
  426.         Begin
  427.           ai := (dy-dx) * 2;
  428.           bi := dy Shl 1;
  429.           d  := bi-dx;
  430.           Repeat
  431.             If (d >= 0) Then
  432.               Begin
  433.                 Inc(y,yi);
  434.                 Inc(d,ai);
  435.                 la^[y] := x;
  436.               End
  437.             Else
  438.               Inc(d,bi);
  439.             Inc(x,xi);
  440.           Until (x = x2);
  441.         End
  442.           Else
  443.             Begin
  444.               ai := (dx-dy) * 2;
  445.               bi := dx Shl 1;
  446.               d  := bi-dy;
  447.               Repeat
  448.                 If (d >= 0) Then
  449.                   Begin
  450.                     Inc(x,xi);
  451.                     Inc(d,ai);
  452.                   End
  453.                 Else
  454.                   Inc(d,bi);
  455.                 Inc(y,yi);
  456.                 la^[y] := x;  {diTo}
  457.               Until(y=y2);
  458.             End;
  459.     End;
  460.  
  461.   {-----------------------------------------------------}
  462.  
  463.   Procedure lInefill(x,y,x2,y2:Word);
  464.  
  465.     Var
  466.       d,dx,dy,ai,bi,xi,yi : Integer;
  467.  
  468.     Begin
  469.       If (x < x2) Then
  470.         Begin
  471.           xi := 1;
  472.           dx := x2-x;
  473.         End
  474.       Else
  475.         Begin
  476.           xi := -1;
  477.           dx := x-x2;
  478.         End;
  479.       yi := 1;
  480.       dy := y2-y;
  481.       If dx > dy Then
  482.         Begin
  483.           ai := (dy - dx) * 2;
  484.           bi := dy Shl 1;
  485.           d  := bi-dx;
  486.           While x <> x2 Do
  487.             Begin
  488.               Repeat
  489.                 If (d >= 0) Then
  490.                   Begin
  491.                     Inc(y,yi);
  492.                     Inc(d,ai);
  493.                     HLin(x,la^[y],y); {Whenever y changes draw hlIne on from
  494.                                            x To la^[y]}
  495.                   End
  496.                 Else
  497.                   Inc(d,bi);
  498.                 Inc(x,xi);
  499.               Until x = x2;
  500.             End;
  501.         End
  502.       Else
  503.         Begin
  504.           ai := (dx - dy) * 2;
  505.           bi := dx Shl 1;
  506.           d  := bi - dy;
  507.           While y <> Y2 Do
  508.             Begin
  509.               Repeat
  510.                 If (d >= 0) Then
  511.                   Begin
  512.                     Inc(x,xi);
  513.                     Inc(d,ai);
  514.                   End
  515.                 Else
  516.                   Inc(d,bi);
  517.                 Inc(y,yi);
  518.                 HLin(x,la^[y],y); {diTo}
  519.               Until y = y2;
  520.             End;
  521.         End;
  522.     End;
  523.  
  524.   {-----------------------------------------------------}
  525.  
  526.   Begin
  527.     Color     := PolCols[pc];
  528.     PolyY[0]  := py[polyst[pc,0]];
  529.     PolyX[0]  := px[polyst[pc,0]];
  530.     PolyY[1]  := py[polyst[pc,1]];
  531.     PolyX[1]  := px[polyst[pc,1]];
  532.     PolyY[2]  := py[polyst[pc,2]];
  533.     PolyX[2]  := px[polyst[pc,2]];
  534.  
  535.    {Sort PolyY. PolyY[0] must be the highest Point}
  536.    {Ployy[2] the lowest}
  537.  
  538.     If PolyY[0]>PolyY[1] Then
  539.       Begin
  540.         s        := PolyY[1];
  541.         PolyY[1] := PolyY[0];
  542.         PolyY[0] := s;
  543.         s        := PolyX[1];
  544.         PolyX[1] := PolyX[0];
  545.         PolyX[0] := s;
  546.       End;
  547.     If PolyY[2] < PolyY[0] Then
  548.       Begin
  549.         s        := PolyY[2];
  550.         PolyY[2] := PolyY[1];
  551.         PolyY[1] := PolyY[0];
  552.         PolyY[0] := s;
  553.         s        := PolyX[2];
  554.         PolyX[2] := PolyX[1];
  555.         PolyX[1] := PolyX[0];
  556.         PolyX[0] := s;
  557.       End
  558.     Else
  559.       If PolyY[2] < PolyY[1] Then
  560.         Begin
  561.           s        := PolyY[1];
  562.           PolyY[1] := PolyY[2];
  563.           PolyY[2] := s;
  564.           s        := PolyX[1];
  565.           PolyX[1] := PolyX[2];
  566.           PolyX[2] := s;
  567.         End;
  568.  
  569.     {Calculate a lIne from the highest To the lowest Point}
  570.     
  571.     FLine(PolyX[0], PolyY[0], PolyX[2], PolyY[2]);
  572.  
  573.     {the xvalues Of the first lIne are now In la[y]}
  574.  
  575.     {calculate the second lIne And fill}
  576.  
  577.     LineFill(PolyX[0], PolyY[0], PolyX[1], PolyY[1]);
  578.  
  579.     {we only use triangles}
  580.  
  581.     LineFill(PolyX[1], PolyY[1], PolyX[2], PolyY[2]);
  582.   End;
  583.  
  584. {-----------------------------------------------------}
  585.  
  586. Procedure Motor;
  587.  
  588.   Begin
  589.     Mcol  := Mcol + Puls;
  590.     If (Mcol = 65) Or (Mcol = 0) Then
  591.       Puls  := -Puls;
  592.     Mcol1   := Mcol1 + Puls1;
  593.     If (Mcol1 = 65) Or (Mcol1 = 0) Then
  594.       Puls1 := -Puls1;
  595.     SetColor(20, Mcol, 10, 10);
  596.     SetColor(21, Mcol1, 10, 10);
  597.   End;
  598.  
  599. {-----------------------------------------------------}
  600.  
  601. Function Sinus(Idx : Byte) : Integer;
  602.  
  603.   Begin
  604.     Sinus := SinTab[Idx];
  605.   End;
  606.  
  607. {-----------------------------------------------------}
  608.  
  609. Function CoSinus(Idx : Byte) : Integer;
  610.  
  611.   Begin
  612.     CoSinus := SinTab[(Idx+192) Mod 255];
  613.   End;
  614.  
  615. {-----------------------------------------------------}
  616.  
  617. {Yeah this is the normal quickSort example from TP.
  618.  there is no faster way To Sort an Array}
  619.  
  620. Procedure QuickSort(Lo, Hi: Integer);
  621.  
  622.   {-----------------------------------------------------}
  623.  
  624.   Procedure Sort(l, r: Integer);
  625.  
  626.     Var
  627.       i, j, x, y: Integer;
  628.  
  629.     Begin
  630.       i := l;
  631.       j := r;
  632.       x := PolyZ[(l+r) Div 2];
  633.       Repeat
  634.         While PolyZ[i] < x Do
  635.           i := i + 1;
  636.         While x < PolyZ[j] Do
  637.           j := j - 1;
  638.         If i <= j Then
  639.           Begin
  640.             y        := PolyZ[i];
  641.             PolyZ[i] := PolyZ[j];
  642.             PolyZ[j] := y;
  643.             y        := Pind[i];
  644.             Pind[i]  := Pind[j];
  645.             Pind[j]  := y;
  646.             i        := i + 1;
  647.             j        := j - 1;
  648.           End;
  649.       Until i > j;
  650.       If l < j Then
  651.         Sort(l, j);
  652.       If i < r Then
  653.         Sort(i, r);
  654.     End;
  655.  
  656.   {-----------------------------------------------------}
  657.   
  658.   Begin {QuickSort};
  659.     Sort(Lo,Hi);
  660.   End;
  661.  
  662. {--------------------MainLoop------------------------------}
  663.  
  664. Begin
  665.   Repeat
  666.     Color  := 0;
  667.  
  668.     SetWindow(0,WOff);           {always draw To a virtual screen}
  669.     WOff   := 200 - WOff;        {flip window}
  670.     ScrOff := $7d00 - ScrOff;    {flip screeNofset}
  671.  
  672.     ClearScreen(ScrOff);         {clear screen And mke lAndscape}
  673.  
  674.     {SetColor(0,40,40,40);}
  675.  
  676.     For I := 0 To NofPoints Do
  677.       Begin
  678.          X1    := (CoSinus(PhiY)*Point[I,0]-Sinus(PhiY)*Point[I,2]) div 128;
  679.          Y1    := (CoSinus(PhiZ)*Point[I,1]-Sinus(PhiZ)*X1) div 128;
  680.          Z1    := (CoSinus(PhiY)*Point[I,2]+Sinus(PhiY)*Point[I,0]) div 128;
  681.          X     := (CoSinus(PhiZ)*X1+Sinus(PhiZ)*Point[I,1]) div 128;
  682.          Y     := (CoSinus(PhiX)*Y1+Sinus(PhiX)*Z1) div 128;
  683.          Z     := (CoSinus(Phix)*Z1-Sinus(Phix)*Y1) div 128;
  684.          PX[I] := 160+(Xc*Z-X*Size) div (Z-Zc) ; {sTOre py}
  685.          PY[I] := 100+wOff+(Yc*Z-Y*Size) div (Z-Zc);{sTOre px}
  686.          PZ[I] := Z;{sTOre pz}
  687.       End;
  688.  
  689.     For I:=0 To Nofpolys Do
  690.       Begin
  691.         PolyZ[I]  := pz[polyst[i,0]];          {Add the zvalues Of}
  692.         PolyZ[I]  := PolyZ[i]+pz[polyst[i,1]]; {the the Points Of }
  693.         PolyZ[I]  := PolyZ[i]+pz[polyst[i,2]]; {the triangle}
  694.         Pind[I]   := I;                        {Index To Point To Polygons}
  695.       End;
  696.  
  697.     QuickSort(0, Nofpolys);        {Sort the z-values Of the polygones
  698.                                      the farest triangle must be drawn first}
  699.  
  700.     Motor;                         {change the Color Of the backtail}
  701.  
  702.     Inc(Phix,xstep);               {Rotate the axis}
  703.     Inc(Phiy,ystep);
  704.     Inc(PhiZ,Zstep);
  705.     d  := 2;                  {you Dont need To draw the farest two polygons}
  706.     WaitRetrace;              {wait For retrace To sync 35fps
  707.                                else it's flickerIng reMove if
  708.                                you have a slow VGA card}
  709.     pc := Pind[0];
  710.     If (pc = 6) Or (pc = 7) Then
  711.       FillPoly;                      {the wings are allways visible}
  712.  
  713.     pc := Pind[1];
  714.     If (pc = 6) Or (pc = 7) Then
  715.       Begin
  716.         FillPoly;
  717.         Inc(d);           {if Pind[1] is a wIng you can flip another polygon}
  718.       End;
  719.  
  720.     For i := d To Nofpolys Do
  721.       Begin
  722.         pc  := Pind[i];
  723.         FillPoly;
  724.         If pc < 2 Then
  725.           Begin                        {0 And 1 are the Toptail}
  726.             pc  := NofPolys + 1 + pc;  {draw the wInDows}
  727.             FillPoly;
  728.           End;
  729.       End;
  730.     Inc(Size,Speed);
  731.     if (Size > 400) Or (Size<50) Then
  732.       Speed := -Speed;
  733.  
  734.     {SetColor(0,0,0,0);}
  735.  
  736.   Until POrt[$60]=1;
  737. End;
  738.       
  739. {--------------------Main--------------------------------}
  740.  
  741. Begin
  742.   GraphBegin;
  743.   CalcSinus(SinTab);
  744.   For I := 0 To NofPolys + 2 Do
  745.     SetColor(PolCols[i], Colors[i,0], Colors[i,1], Colors[i,2]);
  746.   For I := 0 To 9 Do
  747.     SetColor(i+30, BgndCols[i,0], BgndCols[i,1], BgndCols[i,2]);
  748.   New(La); {La is an Array[0..199] YSize 200LInes}
  749.   DoFill;
  750.   Dispose(La);
  751.   GraphEnd;
  752. End.
  753.