home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1998 April A / Pcwk4a98.iso / PROGRAM / DELPHI16 / Disp3d / DOSXYZ.PAS < prev    next >
Pascal/Delphi Source File  |  1995-10-08  |  7KB  |  303 lines
  1.  
  2.  
  3. {$N+,E+}
  4. program DosXYZ;
  5. uses   crt,graph,mouse,graf,Read3d, Rot3D;
  6.  
  7. {++++++++++++++++++++++++++++++++++++++}
  8.  
  9. var   DataFileName : string[80];
  10.       DataRot : RotObj;
  11.       Xp,Yp,W,H,D : integer;
  12.       ch : char;
  13.       Mx,My : integer;
  14.  
  15. const DrawPoints : boolean = false;
  16.       DrawWires : boolean = true;
  17.       NoData : boolean = true;
  18. const UpArrow = char(72+128);
  19.       DnArrow = char(80+128);
  20.       LeftArrow = char(75+128);
  21.       RightArrow = char(77+128);
  22.       PgUp = char(73+128);
  23.       PgDn = char(81+128);
  24.       InsKey = char(82);
  25.       DelKey = char(83);
  26.  
  27. const Change : boolean = true;
  28. const DoPixels : boolean = true;
  29. const RedBlue : boolean = true;
  30.  
  31. type  RectangleType = record x1,y1,x2,y2:word; end;
  32. var   mb : array[0..29] of RectangleType;
  33.       Bret : boolean;
  34.       ScreenSize : word;
  35.       MouseRepeat : boolean;
  36.       Mclk,ClkMask,MouseTime : word;
  37.       SysClock : word absolute $40:$6c;
  38.       done : boolean;
  39.  
  40. type  string20 = string[20];
  41.  
  42. {--------------------------------------------------------}
  43. function fstr(L:longint):string20;
  44. var s : string20;
  45. begin
  46.   str(l,s);
  47.   fstr := s;
  48. end;
  49.  
  50. procedure DrawMouseControls;
  51. type string12 = string[12];
  52.  
  53.   function strL(L:word; d:single):string12;
  54.   var s:string12;
  55.   begin
  56.     str(round(d),s);
  57.     while length(s) < L do
  58.     begin
  59.       inc(s[0]);
  60.       s[length(s)] := ' ';
  61.     end;
  62.     strL := s;
  63.   end;
  64.  
  65.   function DrawMbBox(Index,X,Y:word; s:string12):word;
  66.   begin
  67.     with mb[Index] do
  68.     begin
  69.       x1 := x;
  70.       y1 := y;
  71.       x2 := x+textwidth(s)+10;
  72.       y2 := y+textheight(s)+3;
  73.       setcolor(255);
  74.       rectangle(x1,y1,x2,y2);
  75.       outtextxy(x+2,y,s);
  76.       DrawMbBox := x2;
  77.     end;
  78.   end;
  79.  
  80. var t:word;
  81.     s:string;
  82. begin
  83.   HideMouse;
  84.   SetTextStyle(MyFont,0,4);
  85.   setfillstyle(solidfill,black);
  86.   bar(0,0,GetMaxX,10);
  87.   T := DrawMbBox(0,   1,0,'X: '+strl(4,Xangle));
  88.   T := DrawMbBox(1,T+8,0,'Y: '+strl(4,Yangle));
  89.   T := DrawMbBox(2,T+8,0,'Z: '+strl(4,Zangle));
  90.   s := 'Xs:'+fstr(GetMaxX+1)+' Ys:'+fstr(GetMaxY+1);
  91.   outtextxy(getMaxX-TextWidth(s)-8,0,s);
  92.   ShowMouse;
  93. end;
  94.  
  95. function MouseInMb(Index,X,Y:word):boolean;
  96. begin
  97.   with mb[Index] do
  98.     MouseInMb := (X >= x1) and (X <= x2) and
  99.                  (Y >= Y1) and (Y <= y2);
  100. end;
  101.  
  102.  
  103. {----------------------------------------------------------}
  104.  
  105. procedure DrawIt;
  106. var Q1,Q2,Q3,Q4,LX1,LX2,LY1,LY2,LZ1,LZ2:integer;
  107.   procedure DrawDataPoints;
  108.   var I : integer;
  109.   begin
  110.     for I := 0 to pred(DataItems) do
  111.     begin
  112.       DataRot.PointTransform(Xval^[I],Yval^[I],Zval^[I],LX1,LY1,LZ1);
  113.       PutPixel(Lx1,Ly1,lightgreen);
  114.     end;
  115.   end;
  116.  
  117.     procedure DrawPatch(I:integer);
  118.     var K : integer;
  119.     begin
  120.       for K := 0 to BezierPatternItems-2 do
  121.       begin
  122.         Q1 := Patch^[I][BezierPattern^[K]]-1;
  123.         Q2 := Patch^[I][BezierPattern^[K+1]]-1;
  124.         DataRot.PointTransform(Xval^[Q1],Yval^[Q1],Zval^[Q1],LX1,LY1,LZ1);
  125.         DataRot.PointTransform(Xval^[Q2],Yval^[Q2],Zval^[Q2],LX2,LY2,LZ2);
  126.         MoveTo(Lx1,Ly1);
  127.         LineTo(Lx2,Ly2);
  128.       end;
  129.     end;
  130.  
  131.   procedure DrawDataWires;
  132.   var I:integer;
  133.   begin
  134.     I := 0;
  135.     for I := 0 to PatchLines-1 do
  136.       DrawPatch(I);
  137.   end;
  138.  
  139. begin
  140.   if NoData then Exit;
  141.   SetColor(white);
  142.   DataRot.SetTransformMatrix(Xangle,Yangle,Zangle);
  143.   ClearDevice;
  144.   if DrawWires then
  145.     DrawDataWires;
  146.   if DrawPoints then
  147.     DrawDataPoints;
  148.   DrawMouseControls;
  149. end;
  150.  
  151. procedure TweakAngle(Rev:boolean; Tweak:word; var R:single);
  152. begin
  153.    if Rev then
  154.    begin
  155.      r := r + Tweak;
  156.      if r >= 360 then r := 0;
  157.    end
  158.    else
  159.    begin
  160.      r := r - Tweak;
  161.      if r < 0 then r := 360-Tweak;
  162.    end;
  163. end;
  164.  
  165.  
  166.  
  167. {-------------------------------------------------------------------}
  168. begin
  169.   ExitProc := @EndGraph;
  170.  
  171.   if ParamCount < 1 then
  172.   begin
  173.     writeln('Format is: DOSXYZ filename');
  174.     halt(1);
  175.   end;
  176.  
  177.  
  178.   Datafilename := Paramstr(1);
  179.  
  180.   if ReadConfig(DataFilename) then
  181.   begin
  182.     if not ReadData(DataFilename) then
  183.       NoData := true
  184.     else if not ReadPatch(DataFilename) then
  185.       NoData := true
  186.     else
  187.       NoData := false;
  188.   end;
  189.   if NoData then
  190.   begin
  191.     writeln('Error: file not found:',DataFilename);
  192.     halt(1);
  193.   end;
  194.     
  195.  
  196.   ClkMask := $fffc;
  197.   MouseTime := 0;
  198.   MouseRepeat := false;
  199.   ScreenSize := 200;
  200.   StartGraph(ScreenSize);
  201.   MyFont := LoadFont('LITT.CHR');
  202.   SetTextStyle(MyFont,0,4);
  203.  
  204.   cleardevice;
  205.   setcolor(white);
  206.  
  207.   UseMouseSim := true;
  208.   initmouse;
  209.   SetMousePosition(PutMx(50),PutMy(50));
  210.   ShowMouse;
  211.  
  212.   W := GetMaxY-20;
  213.   H := GetMaxY-20;
  214.   D := GetMaxY-20;
  215.   Xp := GetMaxX div 2;
  216.   Yp := GetMaxY div 2;
  217.   DataRot.SetDataConversion(Xstart,Ystart,Zstart,Xrange,Yrange,Zrange,
  218.                             Xp,Yp,Yp,W,H,D);
  219.   Change := true;
  220.  
  221.   done := false;
  222.   while not done do
  223.   begin
  224.  
  225.     if Change then
  226.     begin
  227.       Drawit;
  228.       Change := false;
  229.       Mclk := SysClock;
  230.     end;
  231.  
  232.     if keypressed then
  233.     begin
  234.       ch := readkey;
  235.       if ch = #0 then
  236.         ch := char(ord(readkey)+128);
  237.  
  238.       case ch of
  239.         'X' : TweakAngle(false,1,Xangle);
  240.         'x' : TweakAngle(true,1,Xangle);
  241.         'Y' : TweakAngle(false,1,Yangle);
  242.         'y' : TweakAngle(true,1,Yangle);
  243.         'Z' : TweakAngle(false,1,Zangle);
  244.         'z' : TweakAngle(true,1,Zangle);
  245.       end;
  246.       case upcase(ch) of
  247.         #$1b : Done := true;
  248.         PgUp: TweakAngle(false,1,Zangle);
  249.         PgDn: TweakAngle(true,1,Zangle);
  250.         UpArrow: TweakAngle(false,1,Xangle);
  251.         DnArrow: TweakAngle(true,1,Xangle);
  252.         LeftArrow: TweakAngle(true,1,Yangle);
  253.         RightArrow: TweakAngle(false,1,Yangle);
  254.       end;
  255.       Change := true;
  256.     end;
  257.  
  258.  
  259.     ReadMouse;
  260.     if MouseButtons <> 0 then
  261.     begin
  262.       if Mclk <> SysClock then
  263.       begin
  264.         Mclk := SysClock;
  265.         inc(MouseTime);
  266.       end;
  267.       if MouseTime > 7 then
  268.         MouseRepeat := true
  269.       else
  270.         MouseRepeat := false;
  271.     end
  272.     else
  273.     begin
  274.       MouseTime := 0;
  275.       MouseRepeat := false;
  276.     end;
  277.  
  278.     if MouseClick or MouseRepeat then
  279.     begin
  280.       Mx := GetMx(MouseX);
  281.       My := GetMy(MouseY);
  282.       Bret := MouseButtons and 1 <> 0;
  283.  
  284.       if      MouseInMb(0,Mx,My) then {Xrot}
  285.       begin
  286.         TweakAngle(Bret,10,Xangle);
  287.       end
  288.       else if MouseInMb(1,Mx,My) then {Yrot}
  289.       begin
  290.         TweakAngle(Bret,10,Yangle);
  291.       end
  292.       else if MouseinMb(2,Mx,My) then {Zrot}
  293.       begin
  294.         TweakAngle(Bret,10,Zangle);
  295.       end;
  296.       Change := true;
  297.     end;
  298.  
  299.   end;
  300.  
  301.   EndGraph;
  302. end.
  303.