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

Pascal/Delphi Source File | 1995-10-08 | 6KB | 261 lines

{$I-,E+,N+}
unit Read3d;
interface

function ReadConfig(Filename:string):boolean;
function ReadData(Filename:string):boolean;
function ReadPatch(Filename:string):boolean;

const MaxItem = pred(65520 div sizeof(Single));
type DataArrayType = array[0..MaxItem] of Single;
type DataArrayPtr = ^DataArrayType;
var Xval,Yval,Zval:DataArrayPtr;
var DataItems : word;

const MaxPatchPoints = 64;
type PatchPoints = array[0..MaxPatchPoints] of Word;
const MaxPatchLine = pred(65520 div sizeof(PatchPoints));
type PatchArrayType = array[0..MaxPatchLine] of PatchPoints;
type PatchArrayPtr = ^PatchArrayType;
var Patch : PatchArrayPtr;
var PatchItems : word;
var PatchLines : word;

const MaxBezierPattern = 31;
type BezierPatternArrayType = array[0..MaxBezierPattern] of word;
type BezierPatternPtr = ^BezierPatternArrayType;
var BezierPattern : BezierPatternPtr;
var BezierPatternItems : word;

var Xstart,YStart,Zstart : single;
var Xrange,Yrange,Zrange : single;

const Xangle : single = 0;
      Yangle : single = 0;
      Zangle : single = 0;

implementation

type string20 = string[20];
var f : text;
    s : string;
    Ts,Ts0,Ts1,Ts2,Ts3 : string20;
    Error,R,j,k,l : integer;

  procedure findnum;
  begin
    while (s[j]<= ' ') or (s[j] = ',') do {find start}
    begin
      if j >= length(s) then break;
      inc(j);
    end;
    k := j;
    while (s[k] <> ',') do  {find end}
    begin
      if k >= length(s) then break;
      inc(k);
    end;
    if k = length(s) then inc(k);
    l := k-j;
    while (s[j+l-1] > '9') or (s[j+l-1] < '0') do
      dec(l);
  end;

  function ReadPoint(var X,Y,Z:single):integer;
  begin
    ReadPoint := -1;
    while true do
    begin
      if eof(f) then
      begin
        ReadPoint := 0;
        Exit;
      end;
      readln(f,s);
      if ioresult <> 0 then Exit;
      if (length(s) > 0) and (s[1] <> ';') then
      begin
        j := 1;
        findnum;
        Ts0 := copy(s,j,l);
        j := succ(k);
        findnum;
        Ts1 := copy(s,j,l);
        j := succ(k);
        findnum;
        Ts2 := copy(s,j,l);
        j := succ(k);
        findnum;
        Ts3 := copy(s,j,l);
        if (length(Ts1) > 0) and (length(Ts2) > 0) and (length(Ts3) > 0) then
        begin
          val(Ts1,X,error);  if error <> 0 then Exit;
          val(Ts2,Y,error);  if error <> 0 then Exit;
          val(Ts3,Z,error);  if error <> 0 then Exit;
          ReadPoint := 1;
          Exit;
        end;
      end;
    end;
  end;

  function ReadPatchLine(PatchLines:word):integer;
  begin
    while true do
    begin
      ReadPatchLine := -1;
      if eof(f) then
      begin
        ReadPatchLine := 0;
        Exit;
      end;
      readln(f,s);
      if ioresult <> 0 then Exit;
      if (length(s) > 0) and (s[1] <> ';') then
      begin
        PatchItems := 0;
        j := 1;
        repeat
          findnum;
          Ts := copy(s,j,l);
          j := succ(k);
          if length(Ts) > 0 then
          begin
            val(Ts,Patch^[PatchLines][PatchItems],error);
            if error <> 0 then
            begin
              ReadPatchLine := -1;
              Exit;
            end;
            inc(PatchItems);
            ReadPatchLine := 1;
          end;
        until length(Ts) = 0;
        if PatchItems > 0 then
          dec(PatchItems);
        Exit;
      end;
    end;
  end;


  function ReadBezierPattern:integer;
  begin
    while true do
    begin
      ReadBezierPattern := -1;
      if eof(f) then
      begin
        ReadBezierPattern := 0;
        Exit;
      end;
      readln(f,s);
      if ioresult <> 0 then Exit;
      if (length(s) > 0) and (s[1] <> ';') then
      begin
        BezierPatternItems := 0;
        j := 1;
        repeat
          findnum;
          Ts := copy(s,j,l);
          j := succ(k);
          if length(Ts) > 0 then
          begin
            val(Ts,BezierPattern^[BezierPatternItems],error);
            if error <> 0 then
            begin
              ReadBezierPattern := -1;
              Exit;
            end;
            inc(BezierPatternItems);
            ReadBezierPattern := 1;
          end;
        until length(Ts) = 0;
        if BezierPatternItems > 0 then
          dec(BezierPatternItems);
        Exit;
      end;
    end;
  end;

function ReadConfig(Filename:string):boolean;
begin
  if ioresult = 0 then {nop};
  ReadConfig := false;
  assign(f,filename+'.PLT');
  reset(f);
  if ReadPoint(Xstart,Ystart,Zstart) < 1 then Exit;
  if ReadPoint(Xrange,Yrange,Zrange) < 1 then Exit;
  if ReadPoint(Xangle,Yangle,Zangle) < 1 then Exit;
  if ReadBezierPattern < 1 then Exit;
  ReadConfig := true;
end;

function ReadData(Filename:string):boolean;
VAR LST:TEXT;
begin

{$ifdef doprint}
ASSIGN(LST,'LPT1');
REWRITE(LST);
WRITELN(LST);
{$endif}

  if ioresult = 0 then {nop};
  ReadData := false;
  assign(f,filename+'.DAT');
  reset(f);
  DataItems := 0;
  R := 1;
  while R > 0 do
  begin
    if DataItems >= MaxItem then Exit;
    R := ReadPoint(Xval^[DataItems],Yval^[DataItems],Zval^[DataItems]);

{$ifdef doprint}
  WRITE(LST,DataItems+1:3,':',TS0,',',TS1,',',TS2,',',TS3,'  ');
  IF DATAITEMS MOD 2 = 1 THEN WRITELN(LST);
{$endif}

    if R < 0 then Exit;
    inc(DataItems);
    ReadData := true;
  end;

  {$ifdef doprint}
    WRITE(LST,^L);
{$endif}

end;

function ReadPatch(Filename:string):boolean;
begin
  if ioresult = 0 then {nop};
  ReadPatch := false;
  assign(f,filename+'.PAT');
  reset(f);
  PatchLines := 0;
  R := 1;
  while R > 0 do
  begin
    if PatchLines >= MaxPatchLine then Exit;
    R := ReadPatchLine(PatchLines);
    if R < 0 then Exit;
    if R > 0 then
      inc(PatchLines);
    ReadPatch := true;
  end;
end;

begin
  new(Xval);
  new(Yval);
  new(Zval);
  new(Patch);
  new(BezierPattern);
  fillchar(patch^,sizeof(Patch^),0);
  fillchar(BezierPattern^,sizeof(BezierPattern^),0);
end.