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