home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1998 April A / Pcwk4a98.iso / PROGRAM / DELPHI16 / Disp3d / DISP3D.PAS < prev    next >
Pascal/Delphi Source File  |  1995-03-02  |  12KB  |  508 lines
  1.  
  2. {$E+,N+}
  3. program disp3d;
  4. uses dos,crt,graph,lad3d,mouse,DataDef,fdata,wrmode,palette,lpunit,graf;
  5.  
  6. const UpArrow = char(72+128);
  7.       DnArrow = char(80+128);
  8.       LeftArrow = char(75+128);
  9.       RightArrow = char(77+128);
  10.       PgUp = char(73+128);
  11.       PgDn = char(81+128);
  12.       InsKey = char(82);
  13.       DelKey = char(83);
  14.  
  15. const Change : boolean = true;
  16. const DoPixels : boolean = true;
  17. const RedBlue : boolean = true;
  18.  
  19. {++++++++++++++++++++++++++++++++++++++}
  20. {test stuf}
  21.  
  22. type  RectangleType = record x1,y1,x2,y2:word; end;
  23. var   mb : array[0..29] of RectangleType;
  24.       Bret : boolean;
  25.       xr,yr,zr:float;
  26.       MouseRepeat : boolean;
  27.       Mclk,ClkMask,MouseTime : word;
  28.       SysClock : word absolute $40:$6c;
  29.       RefX,RefY,RefZ : float;
  30.       PcX,PcY,PcZ : float;
  31.  
  32. type string20 = string[20];
  33. function fstr(D:float):string20;
  34. var s:string20;
  35. begin
  36.   if d >= 100 then
  37.     str(D:1:0,s)
  38.   else if D >= 10 then
  39.     str(D:1:1,s)
  40.   else if D >= 1 then
  41.     str(D:1:2,s)
  42.   else
  43.     str(D:1:4,s);
  44.   fstr := s;
  45. end;
  46. function Lstr(l:longint):string;
  47. var s : string;
  48. begin
  49.   str(l,s);
  50.   Lstr := s;
  51. end;
  52.  
  53.  
  54. {------------------------------------------------}
  55.  
  56. procedure LoadFileList;
  57. var i:word;
  58. begin
  59.   for i := 2 to ParamCount do
  60.   begin
  61.     if DataFileCount >= MaxDataFile then
  62.     begin
  63.       writeln('Error: too many data files (',DataFileCount,')');
  64.       halt(1);
  65.     end;
  66.     DataFileName[DataFileCount] := Paramstr(i);
  67.     inc(DataFileCount);
  68.   end;
  69. end;
  70.  
  71. procedure LoadData;
  72. var i,Dim,Index:word;
  73. begin
  74.   for i := 0 to pred(DataFileCount) do
  75.   begin
  76.     if not ReadFile(DataFileName[i],Dim,Index) then
  77.     begin
  78.       writeln('Error reading file: ',DataFilename[i],' Line:',Index,' Dim:',Dim);
  79.       halt(1);
  80.     end;
  81.   end;
  82. end;
  83.  
  84.  
  85. {===========================================}
  86.  
  87. procedure DrawMouseControls;
  88. type string12 = string[12];
  89.  
  90.   function strL(L:word; d:float):string12;
  91.   var s:string12;
  92.   begin
  93.     str(round(d),s);
  94.     while length(s) < L do
  95.     begin
  96.       inc(s[0]);
  97.       s[length(s)] := ' ';
  98.     end;
  99.     strL := s;
  100.   end;
  101.  
  102.   function DrawMbBox(Index,X,Y:word; s:string12):word;
  103.   begin
  104.     with mb[Index] do
  105.     begin
  106.       x1 := x;
  107.       y1 := y;
  108.       x2 := x+textwidth(s)+10;
  109.       y2 := y+textheight(s)+3;
  110.       setcolor(255);
  111.       rectangle(x1,y1,x2,y2);
  112.       outtextxy(x+2,y,s);
  113.       DrawMbBox := x2;
  114.     end;
  115.   end;
  116.  
  117. var t:word;
  118.     s:string;
  119. begin
  120.   HideMouse;
  121.   SetTextStyle(MyFont,0,4);
  122.   setfillstyle(solidfill,black);
  123.   bar(0,0,GetMaxX,10);
  124.   T := DrawMbBox(0,   1,0,'X: '+strl(4,LadRoot.Xa));
  125.   T := DrawMbBox(1,T+8,0,'Y: '+strl(4,LadRoot.Ya));
  126.   T := DrawMbBox(2,T+8,0,'Z: '+strl(4,LadRoot.Za));
  127.  { T := DrawMbBox(3,T+8,0,'P: '+strl(4,Pcz)); }
  128.   s := 'Xs:'+fstr(GetMaxX+1)+' Ys:'+fstr(GetMaxY+1);
  129.   outtextxy(getMaxX-TextWidth(s)-8,0,s);
  130.   ShowMouse;
  131. end;
  132.  
  133.  
  134. procedure Line3D(x1,y1,z1,x2,y2,z2:integer);
  135. var LX1,LX2,LY1,LY2,LZ1,LZ2:integer;
  136. begin
  137.   LadRoot.transform(x1,y1,z1,LX1,LY1,LZ1);
  138.   LadRoot.transform(x2,y2,z2,LX2,LY2,LZ2);
  139.   with LadRoot,Start do
  140.     line(X+Lx1,Y+Ly1,X+Lx2,Y+Ly2);
  141. end;
  142.  
  143. procedure Draw3Dbox;
  144. var X1,X2,Y1,Y2,Z1,Z2:integer;
  145. begin
  146.   setcolor(255);
  147.   line3D(PlotXmin-1,PlotYmin-1,PlotZmin-1,
  148.          PlotXmax+1,PlotYmin-1,PlotZmin-1);
  149.   line3D(PlotXmin-1,PlotYmin-1,PlotZmin-1,
  150.          PlotXmin-1,PlotYmax+1,PlotZmin-1);
  151.  
  152.   setcolor(254);
  153.   line3D(PlotXmin-1,PlotYmin-1,PlotZmin-1,
  154.          PlotXmin-1,PlotYmin-1,PlotZmax+1);
  155.  
  156.  
  157.   line3D(PlotXmin-1,PlotYmin-1,PlotZmax+1,
  158.          PlotXmin-1,PlotYmax+1,PlotZmax+1);
  159.   line3D(PlotXmin-1,PlotYmax+1,PlotZmax+1,
  160.          PlotXmin-1,PlotYmax+1,PlotZmin-1);
  161.  
  162.   line3D(PlotXmin-1,PlotYmin-1,PlotZmax+1,
  163.          PlotXmax+1,PlotYmin-1,PlotZmax+1);
  164.   line3D(PlotXmax+1,PlotYmin-1,PlotZmax+1,
  165.          PlotXmax+1,PlotYmin-1,PlotZmin-1);
  166.  
  167.   setcolor(255);
  168.   line3D(PlotXmax+1,PlotYmin-1,PlotZmin-1,
  169.          PlotXmax+1,PlotYmax+1,PlotZmin-1);
  170.   line3D(PlotXmax+1,PlotYmax+1,PlotZmin-1,
  171.          PlotXmin-1,PlotYmax+1,PlotZmin-1);
  172. end;
  173.  
  174. procedure Mark3Dbox;
  175. var x1,y1,z1:integer;
  176. var LX1,LY1,LZ1:integer;
  177.     sb,se:float;
  178. begin
  179.   setcolor(255);
  180.   SetTextStyle(MyFont,0,4);
  181.   if (xtype = 0) or (xtype = 1) then
  182.     begin sb := Xstart; se := Xend; end
  183.     else begin se := Xstart; sb := Xend; end;
  184.  
  185.   x1 := PlotXmin;
  186.   y1 := PlotYmax+textwidth('X');
  187.   z1 := PlotZmin;
  188.   LadRoot.transform(x1,y1,z1,LX1,LY1,LZ1);
  189.   with LadRoot,Start do
  190.     outtextxy(x+LX1,y+LY1,fstr(sb));
  191.   x1 := PlotXmax-(textheight('X')*2);
  192.   y1 := PlotYmax+textwidth('X');
  193.   z1 := PlotZmin;
  194.   LadRoot.transform(x1,y1,z1,LX1,LY1,LZ1);
  195.   with LadRoot,Start do
  196.     outtextxy(x+LX1,y+LY1,fstr(se));
  197.  
  198.  
  199.   if (ytype = 0) or (ytype = 1) then
  200.     begin sb := Ystart; se := Yend; end
  201.     else begin se := Ystart; sb := Yend; end;
  202.   x1 := PlotXmax+(textheight('X'));
  203.   y1 := PlotYmin;
  204.   z1 := PlotZmin;
  205.   LadRoot.transform(x1,y1,z1,LX1,LY1,LZ1);
  206.   with LadRoot,Start do
  207.     outtextxy(x+LX1,y+LY1,fstr(sb));
  208.  
  209.   x1 := PlotXmax+(textheight('X'));
  210.   y1 := PlotYmax-(textwidth(fstr(se)));
  211.   z1 := PlotZmin;
  212.   LadRoot.transform(x1,y1,z1,LX1,LY1,LZ1);
  213.   with LadRoot,Start do
  214.     outtextxy(x+LX1,y+LY1,fstr(se));
  215.  
  216.  
  217.   if (ztype = 0) or (ztype = 1) then
  218.     begin sb := Zstart; se := Zend; end
  219.     else begin se := Zstart; sb := Zend; end;
  220.   x1 := PlotXmin;
  221.   y1 := PlotYmax+textwidth('X');
  222.   z1 := PlotZmin+(textheight('X')*2);
  223.   LadRoot.transform(x1,y1,z1,LX1,LY1,LZ1);
  224.   with LadRoot,Start do
  225.     outtextxy(x+LX1,y+LY1,fstr(sb));
  226.  
  227.   x1 := PlotXmin;
  228.   y1 := PlotYmax+textwidth('X');
  229.   z1 := PlotZmax;
  230.   LadRoot.transform(x1,y1,z1,LX1,LY1,LZ1);
  231.   with LadRoot,Start do
  232.     outtextxy(x+LX1,y+LY1,fstr(se));
  233. end;
  234.  
  235. procedure drawdata;
  236. var Bi:word;
  237.     Zt,Xt,Yt:float;
  238.     Xi,Yi,Zi:integer;
  239. begin
  240.   setcolor(255);
  241.   LadRoot.InitTransform;
  242.   LadRoot.xrot(xr);  {init starting angles}
  243.   LadRoot.yrot(yr);
  244.   LadRoot.zrot(zr);
  245.   LadRoot.Setref(RefX,RefY,RefZ);
  246. {  LadRoot.Setpc(PcX,PcY,PcZ); }
  247.  
  248. {  LadRoot.Setref(GxMin+((GxMax-GxMin+1)/2),
  249.                  GyMin+((GyMax-GyMin+1)/2),
  250.                  GzMin+((GzMax-GzMin+1)/2));}
  251.  
  252.   HideMouse;
  253.   cleardevice;
  254.   Draw3DBox;
  255.   Mark3Dbox;
  256.  
  257.   for Bi := 0 to pred(PlotXsize) do
  258.   begin
  259.     Xt := PlotX^[Bi];
  260.     Yt := PlotY^[Bi];
  261.     Zt := PlotZ^[Bi];
  262.     LadRoot.transform(Xt,Yt,Zt,Xi,Yi,Zi);
  263.     Xi := LadRoot.Start.X+Xi;
  264.     Yi := LadRoot.Start.Y+Yi;
  265.     PutPixel(Xi,Yi,{PlotZ^[Bi]} round((GxSize+PlotZ^[Bi])*(253 / (GxSize*2))) );
  266.   end;
  267.   putpixel(LadRoot.Start.X, LadRoot.Start.Y,255);
  268.   ShowMouse;
  269.  
  270.   DrawMouseControls;
  271. end;
  272.  
  273. function MouseInMb(Index,X,Y:word):boolean;
  274. begin
  275.   with mb[Index] do
  276.     MouseInMb := (X >= x1) and (X <= x2) and
  277.                  (Y >= Y1) and (Y <= y2);
  278. end;
  279.  
  280.  
  281. {
  282. procedure mouseoff;
  283. var regs : registers;
  284. begin
  285.   regs.ax := 0;
  286.    regs.bx := 0;
  287.   intr($33,regs);
  288. end;
  289. }
  290.  
  291. procedure TweakAngle(Rev:boolean; Tweak:word; var R:float);
  292. begin
  293.    if Rev then
  294.    begin
  295.      r := r + Tweak;
  296.      if r >= 360 then r := 0;
  297.    end
  298.    else
  299.    begin
  300.      r := r - Tweak;
  301.      if r < 0 then r := 360-Tweak;
  302.    end;
  303. end;
  304.  
  305. procedure TweakNum(Rev:boolean; Tweak:word; var R:float);
  306. begin
  307.    if Rev then
  308.      r := r + Tweak
  309.    else
  310.      r := r - Tweak;
  311. end;
  312.  
  313.  
  314. var result,Mx,My : integer;
  315.     i,gd,gm:integer;
  316.     done:boolean;
  317.     ch:char;
  318.     ExitProc:pointer;
  319.  
  320.  
  321. {-------------------------------------------------------------------}
  322. begin
  323.   ExitProc := @EndGraph;
  324.   Pa := 10;
  325.  
  326.   if ParamCount < 1 then
  327.   begin
  328.     writeln('Format is: DISP3D ConfigFile [Datafile]');
  329.     halt(1);
  330.   end;
  331.   LoadConfigFile(ParamStr(1));
  332.   RefX := 0;
  333.   RefY := 0;
  334.   RefZ := 0;
  335.   PcX := 0;
  336.   PcY := 0;
  337.   PcZ := 0;
  338.  
  339.   ClkMask := $fffc;
  340.   MouseTime := 0;
  341.   MouseRepeat := false;
  342.   fillchar(DataFileName,sizeof(DataFileName),0);
  343.   DataFileCount := 0;
  344. {  ScreenSize := 200; }
  345.   LoadFileList;
  346.   LoadData;
  347.   if not seok then
  348.     ScreenSize := BufSize[0];
  349.   StartGraph(ScreenSize);
  350.   MyFont := LoadFont('LITT.CHR');
  351.   SetTextStyle(MyFont,0,4);
  352.   SetCustomPalette(true,253);
  353. {  CustomBlendPalette(254); }
  354.  
  355. (*
  356.   GxMin := 6*8; GyMin := 10; GzMin := 1;
  357.   GxMax := GetMaxX-GxMin-10;
  358.   GyMax := GetMaxY-GyMin-10;
  359.   GzMax := {254} (GyMax-GyMin) div 4;
  360. *)
  361.  
  362.   GxMin := round(GetMaxY / 3);
  363.   GxMax := GxMin+(GxMin);
  364.   GxSize := GxMax-GxMin;
  365.   GyMin := GxMin;
  366.   GyMax := GxMax;
  367.   GySize := GyMax-GyMin;
  368.   GzMin := 0;
  369.   GzMax := GxMin div 2;
  370.   GzSize := (GzMax-GzMin);
  371.  
  372.  
  373.   Bx := 0;
  374.   By := 1;
  375.   Bz := 2;
  376.  
  377.   if not Xsok then
  378.     Xstart := BufLim[Bx].Min;
  379.   if not Xeok then
  380.     Xend := BufLim[Bx].Max;
  381.   if not Ysok then
  382.     Ystart := BufLim[By].Min;
  383.   if not Yeok then
  384.     Yend := BufLim[By].Max;
  385.   if not Zsok then
  386.     Zstart := BufLim[Bz].Min;
  387.   if not Zeok then
  388.     Zend := BufLim[Bz].Max;
  389.  
  390. {restorecrtmode; }
  391.  
  392.   ConvertToScreenX(Bx,Xtype,Xstart,Xend,-(GxSize),GxSize);
  393.   ConvertToScreenY(By,Ytype,Ystart,Yend,-(GySize),GySize);
  394.   ConvertToScreenZ(Bz,Ztype,Zstart,Zend,-(GzSize),GzSize);
  395.  
  396.   xr := 190;   {starting angles}
  397.   yr := 70;
  398.   zr := 105;
  399.   LadRoot.SetStart(GetMaxX div 2, GetMaxY div 2,0);
  400.  
  401.   cleardevice;
  402.   setcolor(lightgray);
  403.  
  404. {  outtextxy(1,4,'X:'+fstr(GetMaxX)+' Y:'+fstr(GetMaxY)); }
  405.  
  406.   {$IFNDEF DPMI}
  407.     UseSimMouse := true;
  408.   {$ENDIF}
  409.   initmouse;
  410.  
  411.   SetMousePosition(PutMx(50),PutMy(50));
  412.   ShowMouse;
  413.  
  414.   done := false;
  415.   while not done do
  416.   begin
  417.  
  418.  
  419. {    SetFillStyle(0,1); }
  420. {    bar(0,0,GetMaxX,10);
  421.     outtextxy(0,0,'xr:'+fstr(round(xr))+' yr:'+fstr(round(yr))+' zr:'+fstr(round(zr))); }
  422.  
  423.  
  424.     if Change then
  425.     begin
  426.       drawdata;
  427.       Change := false;
  428.       Mclk := SysClock;
  429.     end;
  430.  
  431.     if keypressed then
  432.     begin
  433.       ch := readkey;
  434.       if ch = #0 then
  435.         ch := char(ord(readkey)+128);
  436.  
  437.       case ch of
  438.         'X' : TweakAngle(false,1,PcX);
  439.         'x' : TweakAngle(true,1,PcX);
  440.         'Y' : TweakAngle(false,1,PcY);
  441.         'y' : TweakAngle(true,1,PcY);
  442.         'Z' : Tweaknum(false,1,PcZ);
  443.         'z' : Tweaknum(true,1,PcZ);
  444.       end;
  445.       case upcase(ch) of
  446.         #$1b : Done := true;
  447.         PgUp: TweakAngle(false,1,zr);
  448.         PgDn: TweakAngle(true,1,zr);
  449.         UpArrow: TweakAngle(false,1,xr);
  450.         DnArrow: TweakAngle(true,1,xr);
  451.         LeftArrow: TweakAngle(true,1,yr);
  452.         RightArrow: TweakAngle(false,1,yr);
  453.         'P': PrintScreen(0,200,true);
  454.       end;
  455.       Change := true;
  456.     end;
  457.  
  458.  
  459.     ReadMouse;
  460.     if MouseButtons <> 0 then
  461.     begin
  462.       if Mclk <> SysClock then
  463.       begin
  464.         Mclk := SysClock;
  465.         inc(MouseTime);
  466.       end;
  467.       if MouseTime > 7 then
  468.         MouseRepeat := true
  469.       else
  470.         MouseRepeat := false;
  471.     end
  472.     else
  473.     begin
  474.       MouseTime := 0;
  475.       MouseRepeat := false;
  476.     end;
  477.  
  478.     if MouseClick or MouseRepeat then
  479.     begin
  480.       Mx := GetMx(MouseX);
  481.       My := GetMy(MouseY);
  482.       Bret := MouseButtons and 1 <> 0;
  483.  
  484.       if      MouseInMb(0,Mx,My) then {Xrot}
  485.       begin
  486.         TweakAngle(Bret,10,xr);
  487.       end
  488.       else if MouseInMb(1,Mx,My) then {Yrot}
  489.       begin
  490.         TweakAngle(Bret,10,yr);
  491.       end
  492.       else if MouseinMb(2,Mx,My) then {Zrot}
  493.       begin
  494.         TweakAngle(Bret,10,zr);
  495. (*      end
  496.       else if MouseinMb(3,Mx,My) then {Prot}
  497.       begin
  498.         Tweaknum(Bret,10,Pcz); *)
  499.       end;
  500.       Change := true;
  501.     end;
  502.  
  503.   end;
  504.  
  505.   EndGraph;
  506. end.
  507.  
  508.