PC World Komputer 1998 April A/Pcwk4a98.iso/PROGRAM/DELPHI16/Disp3d/DOSXYZ.PAS

Pascal/Delphi Source File | 1995-10-08 | 6.6 KB | 303 lines

{$N+,E+}
program DosXYZ;
uses   crt,graph,mouse,graf,Read3d, Rot3D;

{++++++++++++++++++++++++++++++++++++++}

var   DataFileName : string[80];
      DataRot : RotObj;
      Xp,Yp,W,H,D : integer;
      ch : char;
      Mx,My : integer;

const DrawPoints : boolean = false;
      DrawWires : boolean = true;
      NoData : boolean = true;
const UpArrow = char(72+128);
      DnArrow = char(80+128);
      LeftArrow = char(75+128);
      RightArrow = char(77+128);
      PgUp = char(73+128);
      PgDn = char(81+128);
      InsKey = char(82);
      DelKey = char(83);

const Change : boolean = true;
const DoPixels : boolean = true;
const RedBlue : boolean = true;

type  RectangleType = record x1,y1,x2,y2:word; end;
var   mb : array[0..29] of RectangleType;
      Bret : boolean;
      ScreenSize : word;
      MouseRepeat : boolean;
      Mclk,ClkMask,MouseTime : word;
      SysClock : word absolute $40:$6c;
      done : boolean;

type  string20 = string[20];

{--------------------------------------------------------}
function fstr(L:longint):string20;
var s : string20;
begin
  str(l,s);
  fstr := s;
end;

procedure DrawMouseControls;
type string12 = string[12];

  function strL(L:word; d:single):string12;
  var s:string12;
  begin
    str(round(d),s);
    while length(s) < L do
    begin
      inc(s[0]);
      s[length(s)] := ' ';
    end;
    strL := s;
  end;

  function DrawMbBox(Index,X,Y:word; s:string12):word;
  begin
    with mb[Index] do
    begin
      x1 := x;
      y1 := y;
      x2 := x+textwidth(s)+10;
      y2 := y+textheight(s)+3;
      setcolor(255);
      rectangle(x1,y1,x2,y2);
      outtextxy(x+2,y,s);
      DrawMbBox := x2;
    end;
  end;

var t:word;
    s:string;
begin
  HideMouse;
  SetTextStyle(MyFont,0,4);
  setfillstyle(solidfill,black);
  bar(0,0,GetMaxX,10);
  T := DrawMbBox(0,   1,0,'X: '+strl(4,Xangle));
  T := DrawMbBox(1,T+8,0,'Y: '+strl(4,Yangle));
  T := DrawMbBox(2,T+8,0,'Z: '+strl(4,Zangle));
  s := 'Xs:'+fstr(GetMaxX+1)+' Ys:'+fstr(GetMaxY+1);
  outtextxy(getMaxX-TextWidth(s)-8,0,s);
  ShowMouse;
end;

function MouseInMb(Index,X,Y:word):boolean;
begin
  with mb[Index] do
    MouseInMb := (X >= x1) and (X <= x2) and
                 (Y >= Y1) and (Y <= y2);
end;


{----------------------------------------------------------}

procedure DrawIt;
var Q1,Q2,Q3,Q4,LX1,LX2,LY1,LY2,LZ1,LZ2:integer;
  procedure DrawDataPoints;
  var I : integer;
  begin
    for I := 0 to pred(DataItems) do
    begin
      DataRot.PointTransform(Xval^[I],Yval^[I],Zval^[I],LX1,LY1,LZ1);
      PutPixel(Lx1,Ly1,lightgreen);
    end;
  end;

    procedure DrawPatch(I:integer);
    var K : integer;
    begin
      for K := 0 to BezierPatternItems-2 do
      begin
        Q1 := Patch^[I][BezierPattern^[K]]-1;
        Q2 := Patch^[I][BezierPattern^[K+1]]-1;
        DataRot.PointTransform(Xval^[Q1],Yval^[Q1],Zval^[Q1],LX1,LY1,LZ1);
        DataRot.PointTransform(Xval^[Q2],Yval^[Q2],Zval^[Q2],LX2,LY2,LZ2);
        MoveTo(Lx1,Ly1);
        LineTo(Lx2,Ly2);
      end;
    end;

  procedure DrawDataWires;
  var I:integer;
  begin
    I := 0;
    for I := 0 to PatchLines-1 do
      DrawPatch(I);
  end;

begin
  if NoData then Exit;
  SetColor(white);
  DataRot.SetTransformMatrix(Xangle,Yangle,Zangle);
  ClearDevice;
  if DrawWires then
    DrawDataWires;
  if DrawPoints then
    DrawDataPoints;
  DrawMouseControls;
end;

procedure TweakAngle(Rev:boolean; Tweak:word; var R:single);
begin
   if Rev then
   begin
     r := r + Tweak;
     if r >= 360 then r := 0;
   end
   else
   begin
     r := r - Tweak;
     if r < 0 then r := 360-Tweak;
   end;
end;



{-------------------------------------------------------------------}
begin
  ExitProc := @EndGraph;

  if ParamCount < 1 then
  begin
    writeln('Format is: DOSXYZ filename');
    halt(1);
  end;


  Datafilename := Paramstr(1);

  if ReadConfig(DataFilename) then
  begin
    if not ReadData(DataFilename) then
      NoData := true
    else if not ReadPatch(DataFilename) then
      NoData := true
    else
      NoData := false;
  end;
  if NoData then
  begin
    writeln('Error: file not found:',DataFilename);
    halt(1);
  end;


  ClkMask := $fffc;
  MouseTime := 0;
  MouseRepeat := false;
  ScreenSize := 200;
  StartGraph(ScreenSize);
  MyFont := LoadFont('LITT.CHR');
  SetTextStyle(MyFont,0,4);

  cleardevice;
  setcolor(white);

  UseMouseSim := true;
  initmouse;
  SetMousePosition(PutMx(50),PutMy(50));
  ShowMouse;

  W := GetMaxY-20;
  H := GetMaxY-20;
  D := GetMaxY-20;
  Xp := GetMaxX div 2;
  Yp := GetMaxY div 2;
  DataRot.SetDataConversion(Xstart,Ystart,Zstart,Xrange,Yrange,Zrange,
                            Xp,Yp,Yp,W,H,D);
  Change := true;

  done := false;
  while not done do
  begin

    if Change then
    begin
      Drawit;
      Change := false;
      Mclk := SysClock;
    end;

    if keypressed then
    begin
      ch := readkey;
      if ch = #0 then
        ch := char(ord(readkey)+128);

      case ch of
        'X' : TweakAngle(false,1,Xangle);
        'x' : TweakAngle(true,1,Xangle);
        'Y' : TweakAngle(false,1,Yangle);
        'y' : TweakAngle(true,1,Yangle);
        'Z' : TweakAngle(false,1,Zangle);
        'z' : TweakAngle(true,1,Zangle);
      end;
      case upcase(ch) of
        #$1b : Done := true;
        PgUp: TweakAngle(false,1,Zangle);
        PgDn: TweakAngle(true,1,Zangle);
        UpArrow: TweakAngle(false,1,Xangle);
        DnArrow: TweakAngle(true,1,Xangle);
        LeftArrow: TweakAngle(true,1,Yangle);
        RightArrow: TweakAngle(false,1,Yangle);
      end;
      Change := true;
    end;


    ReadMouse;
    if MouseButtons <> 0 then
    begin
      if Mclk <> SysClock then
      begin
        Mclk := SysClock;
        inc(MouseTime);
      end;
      if MouseTime > 7 then
        MouseRepeat := true
      else
        MouseRepeat := false;
    end
    else
    begin
      MouseTime := 0;
      MouseRepeat := false;
    end;

    if MouseClick or MouseRepeat then
    begin
      Mx := GetMx(MouseX);
      My := GetMy(MouseY);
      Bret := MouseButtons and 1 <> 0;

      if      MouseInMb(0,Mx,My) then {Xrot}
      begin
        TweakAngle(Bret,10,Xangle);
      end
      else if MouseInMb(1,Mx,My) then {Yrot}
      begin
        TweakAngle(Bret,10,Yangle);
      end
      else if MouseinMb(2,Mx,My) then {Zrot}
      begin
        TweakAngle(Bret,10,Zangle);
      end;
      Change := true;
    end;

  end;

  EndGraph;
end.