home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / egavga.swg / 0113_Cube.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-08-24  |  13.0 KB  |  381 lines
  1. program cube;      { Author: Yves Hetzer   2:248/1003.8  }
  2. uses crt;                   {     Erfurt, Germany }
  3.  
  4. const gCrtc          = $3d4; gScreensize    = 400*80;
  5.       gscreenPage0   = $0000; gScreenpage1   = gscreensize;
  6.       gscreensegment = $0a000; gscrwidth = 80; scal= 20;
  7.       sintab : array[0..90] of byte = (0,4,9,13,18,22,27,31,36,40,44,49,53,58,62,66,71,75,79,83,88,
  8.                                        92,96,100,104,108,112,116,120,124,128,132,136,139,143,147,150,154,158,161,165,
  9.                                        168,171,175,178,181,184,187,190,193,196,199,202,204,207,210,212,215,217,219,222,
  10.                                        224,226,228,230,232,234,236,237,239,241,242,243,245,246,247,248,249,250,251,252,
  11.                                        253,254,254,254,255,255,255,255,255,255);
  12.  
  13. type tupel = record
  14.              x,y,z : integer;
  15.              end;
  16.      rtupel = record
  17.               x,y,z : real;
  18.               end;
  19.      PointType = record
  20.               X, Y : integer;
  21.               end;
  22.      bild_point = array[1..12] of rtupel;
  23.      kehrtab = array [1..10000] of real;
  24.  
  25. const pk : bild_point =((x:0;y:6;z:0),(x:2;y:2;z:2),(x:-2;y:2;z:2),
  26.            (x:2;y:2;z:-2),(x:-2;y:2;z:-2),(x:2;y:-2;z:2),(x:-2;y:-2;z:2),
  27.            (x:2;y:-2;z:-2),(x:-2;y:-2;z:-2),(x:0;y:-6;z:0),(x:6;y:0;z:0),
  28.            (x:-6;y:0;z:0));
  29.  
  30. var scrofs, hlength, scrmemoff,offs,gscreen : word;
  31.     bit_maske :byte;
  32.     rp   : array[1..3,1..3] of real;
  33.     pd  : bild_point;
  34.     u,v:   array[1..12] of integer;
  35.     lauf,al,ga,f,leftb,rightb,upb,downb,help : integer;
  36.     eck : array [0..4] of pointtype;
  37.     kehrt:^kehrtab;
  38.     rmask,lmask:array [0..639] of byte;
  39.  
  40. procedure waitblank;
  41. assembler;
  42. asm;
  43. mov dx,gCRTC+6;@g_r: in al,dx;test al,8;jz @g_r;@g_d: in al,dx;
  44. test al,8;jnz @g_d
  45. end;
  46.  
  47. procedure calcxy;
  48. assembler;
  49. asm;
  50.  mov cx,ax;mov ax,80;mul bx;mov dx,0a000h;push dx;mov dx,ax;
  51.  mov ax,cx;shr ax,1;shr ax,1;shr ax,1;add dx,ax;mov di,dx;
  52.  and cl,7;mov dl,80h;shr dl,cl;pop es;mov ax,gscreen;add di,ax;
  53.  mov ds:[offs], di;mov ds:[bit_maske],dl
  54. end;
  55.  
  56. procedure set_dot(x,y,farbe : word);
  57. assembler;
  58. asm;
  59.  mov ax,x;mov bx,y;mov cx,farbe;call calcxy;mov ah,bit_maske;
  60.  mov dx,3ceh;mov al,08h;out dx,ax;mov ax,0a000h;mov es,ax;
  61.  mov di,offs;mov cx,farbe;mov ch,[es:di];mov [es:di], cl;
  62. end;
  63.  
  64. procedure graph_init;
  65. assembler;
  66. asm;
  67.  mov ax,0012h;int 10h;mov dx,3ceh;mov ax,0205h;out dx,ax;mov ax,1003h;
  68.  out dx,ax;   end;
  69.  
  70. PROCEDURE Draw(xA,yA,xB,yB,col:Integer);     { DRAWALL.INC }
  71. VAR
  72.   x,y,kriterium,dX,dY,stepX,stepY:Integer;
  73. BEGIN
  74.   dX:=Abs(xB-xA);
  75.   dY:=Abs(yB-yA);
  76.   IF dX=0 THEN kriterium:=0 ELSE  kriterium:=Round(-dX/2);
  77.   IF xB>xA THEN stepX:=1 ELSE stepX:=-1;
  78.   IF yB>yA THEN stepY:=1 ELSE stepY:=-1;
  79.   x:=xA;y:=yA;
  80.   set_dot(x,y,col);
  81.   WHILE Not ((x=xB) And (y=yB)) DO
  82.   BEGIN
  83.     IF kriterium <0 THEN
  84.     BEGIN
  85.       x:=x+stepX; kriterium:=kriterium+dY;
  86.     END;
  87.     IF (kriterium>=0) And ( y<>yB) THEN
  88.     BEGIN
  89.       y:=y+stepY; kriterium:=kriterium-dX;
  90.     END;
  91.     set_dot(x,y,col);
  92.   END;
  93. END;
  94.  
  95. procedure hline(x1,x2:integer);
  96. var y : word;
  97. Begin
  98.  if x1>x2 then Begin help := x2;x2:=x1;x1:=help;end;
  99.  help := x1 shr 3;
  100.  scrofs := help + scrmemoff;
  101.  hlength := x2 shr 3 - help;
  102.  if hlength = 0 then
  103.  Begin
  104.   port[$3cf] := lmask[x1] and rmask[x2];
  105.   inc (mem[$a000:scrofs]);
  106.  end else
  107.  if hlength > 1 then
  108.  Begin
  109.   port[$3cf] := lmask[x1];
  110.   inc (mem[$a000:scrofs]);
  111.   port [$3cf] := $ff;
  112.   for lauf := 1 to hlength-1 do inc(mem[$a000:scrofs+lauf]);
  113.   port [$3cf] := rmask[x2];
  114.   inc (mem[$a000:scrofs+hlength]);
  115.  end else
  116.  Begin
  117.   port [$3cf] := lmask [x1];
  118.   inc (mem[$a000:scrofs]);
  119.   port [$3cf] := rmask [x2];
  120.   inc (mem[$a000:scrofs+1]);
  121.  end;
  122. end;
  123.  
  124. procedure fillfourangle(var x1,y1,x2,y2,x3,y3,x4,y4,ficol:integer);
  125. var ho1,ho2,ho3,ho4,ypos,start,ende,diff,counter1,counter2,polyho,
  126.     ya,ye,yr,yl,dy : integer;
  127.     stepx1,stepx2,stepx3,stepx4,links,rechts,xa,xe,xr,xl : longint;
  128.     sre,ore,sl,ol : word;
  129.     trapez,clip : boolean;
  130.     stepx : real;
  131. procedure height (var h : integer);
  132. Begin
  133.  if h = 0 then h := 1 else if h > 5000 then h := 5000;
  134. end;
  135. Begin
  136. asm;mov dx,3ceh;mov ax,0005h;out dx,ax;mov ax,1003h;out dx,ax;end;
  137.  if ((x1<leftb) and (x2<leftb) and (x3<leftb) and (x4<leftb)) or
  138.  ((x1>rightb) and (x2>rightb) and (x3>rightb) and (x4> rightb)) then exit;
  139.  clip := false;
  140.  if (x1<=leftb) or (x2<=leftb) or (x3<=leftb) or (x4<=leftb) or
  141.  (x1>=rightb) or (x2 >= rightb) or (x3 >= rightb) or (x4>=rightb) then clip :=
  142. true;
  143.  eck[1].x := x1;eck[2].x := x2;eck[3].x := x3;eck[4].x := x4;
  144.  eck[1].y := y1;eck[2].y := y2;eck[3].y := y3;eck[4].y := y4;
  145.  for start := 1 to 3 do
  146.  for ende := 4 downto start do
  147.  if eck[start].y > eck[ende].y then begin
  148.  eck[0] := eck[start];
  149.  eck[start] := eck[ende];
  150.  eck[ende] := eck[0];
  151.  end;
  152.  polyho := eck[4].y-eck[1].y;
  153.  if (eck[1].y > downb) or (eck[4].y < upb) or (polyho < 1) then exit;
  154.  dy := eck[4].y - eck[1].y;
  155.  if dy = 0 then dy := 1;
  156.  if dy < 5000 then stepx := (eck[4].x-eck[1].x)*kehrt^[dy] else
  157.     stepx := (eck[4].x-eck[1].x)/dy;
  158.  xa := trunc ((eck[2].y-eck[1].y)*stepx+eck[1].x);
  159.  xe := trunc (eck[4].x-(eck[4].y-eck[3].y)*stepx);
  160.  if ((xa<eck[2].x)and(xe<eck[3].x)) or ((xa>eck[2].x) and (xe>eck[3].x))
  161.     then trapez := true else trapez := false;
  162.  xa := eck[1].x; xa := xa * 256;ya := eck[1].y; xe := eck[4].x;
  163.  xe := xe * 256; ye := eck[4].y;xl := eck[2].x; xl := xl * 256;
  164.  yl := eck[2].y; xr := eck[3].x;xr := xr * 256; yr := eck[3].y;
  165. if not trapez then
  166. Begin
  167.  ho1 := abs(yr-ya);ho2 := abs(ye-yr);height (ho1);height (ho2);
  168.  stepx1 := trunc((xr-xa)*kehrt^[ho1]);stepx2 := trunc((xe-xr)*kehrt^[ho2]);
  169.  ho4 := abs(yl-ya);ho3 := abs(ye-yl);height (ho4);height (ho3);
  170.  stepx4 := trunc((xl-xa)*kehrt^[ho4]);stepx3 := trunc((xe-xl)*kehrt^[ho3]);
  171. end else
  172. Begin
  173.  ho1 := abs(yl-ya);ho2 := abs(yr-yl);height (ho1);height (ho2);
  174.  stepx1 := trunc((xl-xa)*kehrt^[ho1]);stepx2 := trunc((xr-xl)*kehrt^[ho2]);
  175.  ho4 := abs(ye-ya);ho3 := abs(ye-yr);height (ho4);height (ho3);
  176.  stepx4 := trunc((xe-xa)*kehrt^[ho4]);stepx3 := trunc((xe-xr)*kehrt^[ho3]);
  177. end;
  178.  port[$3ce] := 1; port[$3cf] := $0f;port[$3ce] := 0; port[$3cf]:=ficol;
  179.  port[$3ce] := 8;
  180.  links := xa; rechts := links; start := ya; ende := start + polyho - 1;
  181.  counter1:= 0; counter2 :=0;
  182.  if start < upb then Begin
  183.      diff := upb - start;inc (start,diff);inc (counter1,diff);
  184.      if not trapez then Begin
  185.          inc (counter2,diff);
  186.          if counter2<ho4 then inc (links,diff*stepx4)
  187.          else links := xl + (upb-yl)*stepx3;
  188.          if counter1<ho1 then inc(rechts,diff*stepx1)
  189.          else rechts := xr + (upb-yr)*stepx2;
  190.      end else Begin
  191.          inc(links,diff*stepx4);
  192.          if counter1<ho1 then inc(rechts,diff*stepx1)
  193.          else Begin
  194.            inc (counter2,diff-ho1);
  195.            if counter2 < ho2 then rechts := xl + (upb-yl)*stepx2
  196.            else rechts := xr + (upb-yr)*stepx3;
  197.          end;
  198.      end;
  199.  end;
  200.  scrmemoff := gscreen+start*gscrwidth;
  201.  if ende > downb then ende := downb;
  202.  sl := seg(links);ol := ofs(links)+1;sre := seg(rechts);ore := ofs(rechts)+1;
  203.   if not trapez then
  204.   begin
  205.    for ypos := start to ende do
  206.     begin
  207.      if counter2< ho4 then
  208.      Begin
  209.       inc(links,stepx4);inc(counter2);
  210.      end else inc(links,stepx3);
  211.      if counter1<ho1 then
  212.      begin
  213.       inc(rechts,stepx1);inc(counter1);
  214.      end else inc (rechts,stepx2);
  215.      hline(memw[sl:ol],memw[sre:ore]);
  216.      inc(scrmemoff,gscrwidth);
  217.    end;
  218.   end else
  219.   begin
  220.   for ypos := start to ende do
  221.   begin
  222.    inc(links,stepx4);
  223.    if counter1<ho1 then
  224.    begin
  225.     inc(rechts,stepx1);inc(counter1);
  226.    end else
  227.    if counter2<ho2 then
  228.    begin
  229.     inc(rechts,stepx2);inc(counter2);
  230.    end else inc(rechts,stepx3);
  231.    hline(memw[sl:ol],memw[sre:ore]);
  232.    inc(scrmemoff,gscrwidth);
  233.   end;
  234.  end;
  235. port [$3cf] := $ff; port[$3ce] := 1;port [$3cf] := 0; port [$3ce] := 0;
  236. port [$3cf] := 15;
  237. end;
  238.  
  239. procedure setrgbpalette(i,r,g,b : byte);
  240. begin
  241. asm;mov dx,3c8h;mov al,i;out dx,al;inc dx;mov al,r;out dx,ax;mov al,g;
  242. out dx,al;mov al,b;out dx,al;end;end;
  243.  
  244. function csin(winkel :integer): integer;
  245. begin
  246. while winkel < 0 do winkel := winkel + 360;
  247. winkel := winkel mod 360;
  248. if (winkel >= 0) and (winkel <= 90) then csin := sintab[winkel];
  249. if (winkel > 90) and (winkel <= 180) then csin := sintab[180-winkel];
  250. if (winkel > 180) and (winkel <= 270) then csin := -sintab[winkel-180];
  251. if (winkel > 270) and (winkel <= 360) then csin := -sintab[360-winkel];
  252. end;
  253.  
  254. function ccos(winkel :integer): integer;
  255. begin
  256. winkel := winkel+ 90;
  257. while winkel < 0 do winkel := winkel + 360;
  258. winkel := winkel mod 360;
  259. ccos := csin(winkel);
  260. end;
  261.  
  262. procedure gstartaddr(addr : word);
  263. assembler;
  264. asm;
  265. mov bx,addr;push ds;mov dx,gCRTC;mov ah,bh;mov al,0ch;out dx,ax;
  266. mov ah,bl;mov al,0dh;out dx,ax;mov cx,0040h;mov ds,cx;
  267. mov word ptr ds:[004eh],bx;pop ds;end;
  268.  
  269. procedure waehle_seite (seite : byte);
  270. begin
  271. gscreen := seite * gscreensize;
  272. end;
  273.  
  274. procedure zeige_seite(seite : byte);
  275. var adr : word;
  276. begin
  277.  adr := seite * gscreensize;
  278.  gstartaddr (adr);
  279. end;
  280.  
  281. procedure wechsel5;
  282.  
  283. begin
  284. if gscreen = gscreenpage0 then begin
  285.                                 zeige_seite(0); waehle_seite(1); end
  286.                                else begin
  287.                                 zeige_seite(1); waehle_seite(0);
  288.                                end;
  289. end;
  290.  
  291. procedure gclear;
  292. assembler;
  293. asm;
  294. mov ax,gscreensegment;mov es,ax;mov al,es:[0];mov di,gscreen;mov dx,3ceh;
  295. mov ax,0205h;out dx,ax;mov ax,0003h;out dx,ax;mov ax,0ffffh;out dx,ax;
  296. mov ax,$00;mov cx,gscreensize/2;rep stosw;mov dx,3ceh;mov ax,0205h;out dx,ax;
  297. mov ax,1003h;out dx,ax;end;
  298.  
  299. procedure dreh_m;
  300. var x,y,u,v : real;
  301. begin
  302.  x:=csin(ga)/256; y:=ccos(al)/256; u:=csin(al)/256; v:=ccos(ga)/256;
  303.  rp[1,1]:=v; rp[2,1]:=x; rp[3,1]:=0; rp[1,2]:=y*x; rp[2,2]:=y*v; rp[3,2]:=-u;
  304.  rp[1,3]:=u*x; rp[2,3]:=u*v; rp[3,3]:=y;end;
  305.  
  306. procedure dreh(var x:rtupel);
  307. var temp:rtupel;
  308. begin
  309.  temp.x:=(x.x*rp[1,1]+x.y*rp[1,2]+x.z*rp[1,3]) * scal;
  310.  temp.y:=(x.x*rp[2,1]+x.y*rp[2,2]+x.z*rp[2,3])*scal;
  311.  temp.z:=(x.y*rp[3,2]+x.z*rp[3,3])*scal;
  312.  x:=temp;
  313. end;
  314.  
  315. procedure zeichnen;
  316. begin
  317. for lauf := 1 to 12 do begin
  318. u[lauf] := round(pd[lauf].x)+320;v[lauf] := round(pd[lauf].z)+200;end;
  319.  
  320. draw(u[1],v[1],u[2],v[2],1);draw(u[1],v[1],u[4],v[4],1);
  321. draw(u[1],v[1],u[3],v[3],1);draw(u[1],v[1],u[5],v[5],1);
  322. draw(u[2],v[2],u[3],v[3],1);draw(u[2],v[2],u[4],v[4],1);
  323. draw(u[3],v[3],u[5],v[5],1);draw(u[5],v[5],u[4],v[4],1);
  324. draw(u[6],v[6],u[7],v[7],1);draw(u[6],v[6],u[8],v[8],1);
  325. draw(u[7],v[7],u[9],v[9],1);draw(u[9],v[9],u[8],v[8],1);
  326. draw(u[2],v[2],u[6],v[6],1);draw(u[3],v[3],u[7],v[7],1);
  327. draw(u[4],v[4],u[8],v[8],1);draw(u[5],v[5],u[9],v[9],1);
  328. draw(u[10],v[10],u[6],v[6],1);draw(u[10],v[10],u[7],v[7],1);
  329. draw(u[10],v[10],u[8],v[8],1);draw(u[10],v[10],u[9],v[9],1);
  330. draw(u[11],v[11],u[6],v[6],1);draw(u[11],v[11],u[2],v[2],1);
  331. draw(u[11],v[11],u[8],v[8],1);draw(u[11],v[11],u[4],v[4],1);
  332. draw(u[12],v[12],u[3],v[3],1);draw(u[12],v[12],u[5],v[5],1);
  333. draw(u[12],v[12],u[7],v[7],1);draw(u[12],v[12],u[9],v[9],1); end;
  334.  
  335. procedure initkehrtaB;
  336. var a: word;
  337. begin new (kehrt); for a:= 1 to 10000 do kehrt^[a] := 1/a; end;
  338.  
  339. procedure initmasktab;
  340. var a,wert : word;
  341. begin
  342.  for a:= 0 to 639 do
  343.  begin
  344.   lmask[a]:=$ff shr (a and 7);wert := $ff shl (7-(a and 7));
  345.   rmask[a] := lo(wert); end;end;
  346.  
  347. procedure gexit;
  348. assembler; asm;push ax;xor ah,ah;mov al,3h;int 10h;pop ax;end;
  349.  
  350.  
  351. begin
  352.   graph_init;
  353.   setrgbpalette(1,63,0,0); setrgbpalette(2,0,42,0); setrgbpalette(3,10,63,10);
  354.   setrgbpalette(4,42,0,0); setrgbpalette(5,63,10,10);setrgbpalette(6,42,21,0);
  355.   setrgbpalette(7,42,42,42);
  356.   gscreen := 0; initkehrtab; initmasktab;
  357.   al := 0; ga := 0;leftb := 10;upb := 10;rightb := 600;downb := 400;
  358.   repeat
  359.    dec(al,5);ga := ga + csin(al) div 25+csin(ga) div 50;pd := pk;
  360.    dreh_m;for lauf := 1 to 12 do dreh(pd[lauf]);
  361.   zeichnen;f := 2;
  362.   fillfourangle(u[1],v[1],u[4],v[4],u[5],v[5],u[1],v[1],f);
  363.   fillfourangle(u[1],v[1],u[2],v[2],u[3],v[3],u[1],v[1],f);
  364.   fillfourangle(u[1],v[1],u[5],v[5],u[3],v[3],u[1],v[1],f);
  365.   fillfourangle(u[1],v[1],u[2],v[2],u[4],v[4],u[1],v[1],f);f := 4;
  366.   fillfourangle(u[11],v[11],u[2],v[2],u[6],v[6],u[11],v[11],f);
  367.   fillfourangle(u[11],v[11],u[4],v[4],u[8],v[8],u[11],v[11],f);
  368.   fillfourangle(u[11],v[11],u[6],v[6],u[8],v[8],u[11],v[11],f);
  369.   fillfourangle(u[11],v[11],u[2],v[2],u[4],v[4],u[11],v[11],f);f := 2;
  370.   fillfourangle(u[10],v[10],u[8],v[8],u[9],v[9],u[10],v[10],f);
  371.   fillfourangle(u[10],v[10],u[6],v[6],u[7],v[7],u[10],v[10],f);
  372.   fillfourangle(u[10],v[10],u[9],v[9],u[7],v[7],u[10],v[10],f);
  373.   fillfourangle(u[10],v[10],u[6],v[6],u[8],v[8],u[10],v[10],f);f := 4;
  374.   fillfourangle(u[12],v[12],u[3],v[3],u[7],v[7],u[12],v[12],f);
  375.   fillfourangle(u[12],v[12],u[5],v[5],u[9],v[9],u[12],v[12],f);
  376.   fillfourangle(u[12],v[12],u[3],v[3],u[5],v[5],u[12],v[12],f);
  377.   fillfourangle(u[12],v[12],u[7],v[7],u[9],v[9],u[12],v[12],f);
  378.   wechsel5; waitblank; gclear;
  379.  until keypressed;
  380. dispose(kehrt);gexit;end.
  381.