home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / graphics.swg / 0121_Moving Poligon.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-08-24  |  9.7 KB  |  380 lines
  1. {
  2. PS> I see that a lot of people around here have polygon, texture mapping and
  3. PS> 3D routines so why don't you all post them here, even if you already
  4. PS> have done in the past cause there are people who didn't get them
  5. PS> and want them :)
  6. }
  7.  
  8. {$G+,R-}
  9. Program Polygoned_and_shaded_objects;
  10.  
  11. { Mode-x version of polygoned objects          }
  12. { Originally by Bas van Gaalen & Sven van Heel }
  13. { Optimized by Luis Mezquita Raya              }
  14.  
  15. uses Crt,x3Dunit2;
  16.          { ^^^^^  Contained in GRAPHICS.SWG file }
  17. {$DEFINE Object1}                       { Try an object between 1..4 }
  18.  
  19. const
  20.  
  21. {$IFDEF Object1}                        { Octagon }
  22.  nofpolys=9;                            { Number of poligons-1 }
  23.  
  24.  nofpoints=11;                          { Number of points-1 }
  25.  
  26.  polypoints=4;                          { Number of points for each poly }
  27.  
  28.  sc=5;                                  { Number of visible planes }
  29.  
  30.  cr=23;                                 { RGB components }
  31.  cg=8;
  32.  cb=3;
  33.  
  34.  point:array[0..nofpoints,0..2] of integer=(
  35.     (-20,-20, 30),( 20,-20, 30),( 40,-40,  0),( 20,-20,-30),
  36.     (-20,-20,-30),(-40,-40,  0),(-20, 20, 30),( 20, 20, 30),
  37.     ( 40, 40,  0),( 20, 20,-30),(-20, 20,-30),(-40, 40,  0));
  38.  
  39.  planes:array[0..nofpolys,0..3] of byte=(
  40.     (0,1,7,6),(1,2,8,7),(9,8,2,3),(10,9,3,4),(10,4,5,11),
  41.     (6,11,5,0),(0,1,2,5),(5,2,3,4),(6,7,8,11),(11,8,9,10));
  42. {$ENDIF}
  43.  
  44. {$IFDEF Object2}                        { Cube }
  45.  nofpolys=5;                            { Number of poligons-1 }
  46.  
  47.  nofpoints=7;                           { Number of points-1 }
  48.  
  49.  polypoints=4;                          { Number of points for each poly }
  50.  
  51.  sc=3;                                  { Number of visible planes }
  52.  
  53.  cr=0;                                  { RGB components }
  54.  cg=13;
  55.  cb=23;
  56.  
  57.  point:array[0..nofpoints,0..2] of integer=(
  58.     (-40,-40, 40),( 40,-40, 40),( 40,-40,-40),(-40,-40,-40),
  59.     (-40, 40, 40),( 40, 40, 40),( 40, 40,-40),(-40, 40,-40));
  60.  
  61.  planes:array[0..nofpolys,0..3] of byte=(
  62.     (0,1,5,4),(1,5,6,2),(6,7,3,2),
  63.     (7,3,0,4),(0,1,2,3),(6,5,4,7));
  64. {$ENDIF}
  65.  
  66. {$IFDEF Object3}                        { Octahedron }
  67.  nofpolys=7;                            { Number of poligons-1 }
  68.  
  69.  nofpoints=5;                           { Number of points-1 }
  70.  
  71.  polypoints=3;                          { Number of points for each poly }
  72.  
  73.  sc=4;                                  { Number of visible planes }
  74.  
  75.  cr=0;                                  { RGB components }
  76.  cg=3;
  77.  cb=23;
  78.  
  79.  point:array[0..nofpoints,0..2] of integer=(
  80.     (  0, 0,  45),(-40,-40,  0),(-40, 40,  0),( 40, 40,  0),
  81.     ( 40,-40,  0),(  0,  0,-45));
  82.  
  83.  planes:array[0..nofpolys,0..3] of byte=(
  84.     (0,1,2,0),(0,2,3,0),(0,3,4,0),(0,4,1,0),
  85.     (5,1,2,5),(5,2,3,5),(5,3,4,5),(5,4,1,5));
  86.  
  87. {$ENDIF}
  88.  
  89. {$IFDEF Object4}                        { Spiky }
  90.  nofpolys=15;                           { Number of poligons-1 }
  91.  
  92.  nofpoints=19;                          { Number of points-1 }
  93.  
  94.  polypoints=4;                          { Number of points for each poly }
  95.  
  96.  sc=5;                                  { Number of visible planes }
  97.  
  98.  cr=23;                                 { RGB components }
  99.  cg=5;
  100.  cb=5;
  101.  
  102.  point:array[0..nofpoints,0..2] of integer=(
  103.     (-10,-10, 30),( 10,-10, 30),( 30,-30,  0),( 10,-10,-30),
  104.     (-10,-10,-30),(-30,-30,  0),(-10, 10, 30),( 10, 10, 30),
  105.     ( 30, 30,  0),( 10, 10,-30),(-10, 10,-30),(-30, 30,  0),
  106.     ( -2, -2, 60),( -2,  2, 60),(  2, -2, 60),(  2,  2, 60),
  107.     ( -2, -2,-60),( -2,  2,-60),(  2, -2,-60),(  2,  2,-60));
  108.  
  109.  planes:array[0..nofpolys,0..3] of byte=(
  110.     (0,1,14,12),(7,15,13,6),(1,14,15,7),(6,13,12,0),
  111.     (1,2,8,7),(9,8,2,3),
  112.     (10,9,19,17),(10,4,16,17),(3,4,16,18),(3,9,19,18),
  113.     (10,4,5,11),
  114.     (6,11,5,0),(0,1,2,5),(5,2,3,4),(6,7,8,11),(11,8,9,10));
  115. {$ENDIF}
  116.  
  117. type  polytype=array[0..nofpolys] of integer;
  118.       pointype=array[0..nofpoints] of integer;
  119.  
  120.       ptnode=word;
  121.       stack=ptnode;
  122.  
  123. const soplt=SizeOf(polytype);
  124.       sopit=SizeOf(pointype);
  125.       xst:integer=1;
  126.       yst:integer=1;
  127.       zst:integer=-2;
  128.  
  129. var   polyz,pind:array[byte] of polytype;
  130.       xp,yp:array[byte] of pointype;
  131.       phix:byte;
  132.  
  133. Procedure QuickSort(lo,hi:integer); assembler; { Iterative QuickSort }
  134. var i,j,x,y:integer;                           { NON RECURSIVE }
  135. asm
  136.         mov ah,48h                      { Init stack }
  137.         mov bx,1
  138.         int 21h
  139.         jc @exit
  140.         mov es,ax
  141.         xor ax,ax
  142.         mov es:[4],ax
  143.  
  144.         mov cx,lo                       { Push(lo,hi) }
  145.         mov dx,hi
  146.         call @Push
  147.  
  148. @QS:    mov ax,es:[4]                   { ¿Stack empty? }
  149.         and ax,ax
  150.         jz @Empty
  151.  
  152.         mov cx,es:[0]                   { Top(lo,hi) }
  153.         mov dx,es:[2]
  154.         mov lo,cx
  155.         mov hi,dx
  156.  
  157.         mov bx,es:[4]                   { Pop }
  158.         mov ah,49h
  159.         int 21h
  160.         jc @exit
  161.         mov es,bx
  162.  
  163.         mov ax,cx                       { ax:=(i+j) div 2 }
  164.         mov bx,dx
  165.         add ax,bx
  166.         shr ax,1
  167.  
  168.         lea bx,polyz                    { ax:=polyz[ax] }
  169.         call @index
  170.         mov x,ax
  171.  
  172. @Rep:   mov ax,cx                       { repeat ... }
  173.         lea bx,polyz                    { while polyz[i]<x do ... }
  174.         call @index
  175.         cmp ax,x
  176.         jge @Rep2
  177.         inc cx                          { inc(i); }
  178.         jmp @Rep
  179.  
  180. @Rep2:  mov ax,dx                       { while x<polyz[j] do ... }
  181.         call @index
  182.         cmp x,ax
  183.         jge @EndR
  184.         dec dx                          { dec(j); }
  185.         jmp @Rep2
  186.  
  187. @EndR:  cmp cx,dx                       { if i>j ==> @NSwap}
  188.         jg @NBl
  189.  
  190.         je @NSwap
  191.         push cx
  192.  
  193.         mov ax,cx
  194.         call @index
  195.         mov cx,ax                       { cx:=polyz[i] }
  196.         mov si,di
  197.  
  198.         mov ax,dx                       { polyz[i]:=polyz[j] }
  199.         call @index
  200.         mov [si],ax
  201.  
  202.         mov [di],cx                     { polyz[j]:=cx }
  203.         pop ax
  204.  
  205.         push ax
  206.         lea bx,pind
  207.         call @index
  208.         mov cx,ax                       { cx:=pind[i] }
  209.         mov si,di
  210.  
  211.         mov ax,dx                       { pind[i]:=pind[j] }
  212.         call @index
  213.         mov [si],ax
  214.  
  215.         mov [di],cx                     { pind[j]:=cx }
  216.  
  217.         pop cx
  218. @NSwap: inc cx
  219.         dec dx
  220.  
  221. @NBl:   cmp cx,dx                       { ... until i>j; }
  222.         jle @Rep
  223.  
  224.         mov i,cx
  225.         mov j,dx
  226.  
  227.         mov dx,hi                       { if i>=hi ==> @ChkLo }
  228.         cmp cx,dx
  229.         jge @ChkLo
  230.  
  231.         call @Push                      { Push(i,hi) }
  232.  
  233. @ChkLo: mov cx,lo                       { if lo>=j ==> @QSend }
  234.         mov dx,j
  235.         cmp cx,dx
  236.         jge @QSend
  237.  
  238.         call @Push                      { Push(lo,j) }
  239.  
  240. @QSend: jmp @QS                         { loop while stack isn't empty }
  241.  
  242. @Empty: mov ah,49h
  243.         int 21h
  244.         jmp @exit
  245.  
  246. @index: shl ax,1                        { ax:=2*ax }
  247.         add ax,bx
  248.         mov di,ax
  249.         push bx
  250.         mov bl,soplt
  251.         mov al,phix
  252.         xor ah,ah
  253.         mul bl
  254.         add di,ax                       { di=2*index+SizeOf(polytype)+polyz }
  255.         pop bx
  256.         mov ax,[di]
  257.         ret
  258.  
  259. @Push:  mov ah,48h                      { Push into stack }
  260.         mov bx,1
  261.         int 21h
  262.         jc @exit
  263.         mov bx,es
  264.         mov es,ax
  265.         mov es:[0],cx
  266.         mov es:[2],dx
  267.         mov es:[4],bx
  268.         mov di,ax
  269.         ret
  270.  
  271. @exit:
  272. end;
  273.  
  274. Procedure Calc;
  275. var z:pointype;
  276.     spx,spy,spz,
  277.     cpx,cpy,cpz,
  278.     zd,x,y,i,j,k:integer;
  279.     n,key,phiy,phiz:byte;
  280. begin
  281.  phix:=0;
  282.  phiy:=0;
  283.  phiz:=0;
  284.  FillChar(xp,sizeof(xp),0);
  285.  FillChar(yp,sizeof(yp),0);
  286.  
  287.  repeat
  288.  
  289.   spx:=sinus(phix);                     { 'Precookied' constanst }
  290.   spy:=sinus(phiy);
  291.   spz:=sinus(phiz);
  292.  
  293.   cpx:=cosinus(phix);
  294.   cpy:=cosinus(phiy);
  295.   cpz:=cosinus(phiz);
  296.  
  297.   for n:=0 to nofpoints do
  298.    begin
  299.     i:=(cpy*point[n,0]-spy*point[n,2]) div divd;
  300.     j:=(cpz*point[n,1]-spz*i) div divd;
  301.     k:=(cpy*point[n,2]+spy*point[n,0]) div divd;
  302.     x:=(cpz*i+spz*point[n,1]) div divd;
  303.     y:=(cpx*j+spx*k) div divd;
  304.     z[n]:=(cpx*k-spx*j) div divd;
  305.     zd:=z[n]-dist;
  306.     xp[phix,n]:=(160+cpx)-(x*dist) div zd;
  307.     yp[phix,n]:=(200+spz) div 2-(y*dist) div zd;
  308.    end;
  309.  
  310.   for n:=0 to nofpolys do
  311.    begin
  312.     polyz[phix,n]:=(z[planes[n,0]]+z[planes[n,1]]+
  313.                     z[planes[n,2]]+z[planes[n,3]]) div 4;
  314.     pind[phix,n]:=n;
  315.    end;
  316.  
  317.   QuickSort(0,nofpolys);
  318.   inc(phix,xst);
  319.   inc(phiy,yst);
  320.   inc(phiz,zst);
  321.  until phix=0;
  322. end;
  323.  
  324. Procedure ShowObject;
  325. var n:byte; pim:integer;
  326. begin
  327.  retrace;
  328.  if address=0
  329.  then address:=16000
  330.  else address:=0;
  331.  setaddress(address);
  332.  cls;
  333.  for n:=sc to nofpolys do
  334.   begin
  335.    pim:=pind[phix,n];
  336.    polygon(xp[phix,planes[pim,0]],yp[phix,planes[pim,0]],
  337.            xp[phix,planes[pim,1]],yp[phix,planes[pim,1]],
  338.            xp[phix,planes[pim,2]],yp[phix,planes[pim,2]],
  339.            xp[phix,planes[pim,3]],yp[phix,planes[pim,3]],
  340.            polyz[phix,n]+30);
  341.   end;
  342. end;
  343.  
  344. Procedure Rotate;
  345. var i:byte;
  346. begin
  347.  setmodex;
  348.  address:=0;
  349.  Triangles:=polypoints=3;
  350.  for i:=1 to 80 do setpal(i,cr+i shr 1,cg+i shr 1,cb+i shr 1);
  351.  setborder(63);
  352.  repeat
  353.   ShowObject;
  354.   inc(phix,xst);
  355.  until KeyPressed;
  356.  setborder(0);
  357. end;
  358.  
  359. var i:byte;
  360.     s:stack;
  361.     x,y:integer;
  362.  
  363. begin
  364.  {border:=True;}
  365.  if ParamCount=1
  366.  then begin
  367.        Val(ParamStr(1),xst,yst);
  368.        if yst<>0 then Halt;
  369.        zst:=-2*xst;
  370.        yst:=xst;
  371.       end;
  372.  WriteLn('Wait a moment ...');
  373.  Calc;
  374.  Rotate;
  375.  TextMode(LastMode);
  376. end.
  377.  
  378.         But ... wait a moment ... you also need x3dUnit2.pas
  379.         which is also included in the SWAG files
  380.