Virtual Reality Homebrewer's Handbook/vr.iso/vroom/plg_2_3d.pas

Pascal/Delphi Source File | 1996-03-19 | 12KB | 375 lines

program test;

var temp_string, input_file, output_file : string;
    fin, fout : text;
    string_length, hash_pos, mode, temp, vertices, faces, count: integer;
    vertex_x, vertex_y, vertex_z, scale : real;

type
    plg_face_vertexptr=^plg_face_vertex;
    plg_face_vertex=record
       vertex_num : integer;
       next : plg_face_vertexptr;
    end;

function empty_string(this_string : string) : boolean;
begin
     for count:=1 to length(this_string) do
     begin
          if ((this_string[count]>='0') and (this_string[count]<='9'))
          or ((this_string[count]>='a') and (this_string[count]<='z'))
          or ((this_string[count]>='A') and (this_string[count]<='Z'))
          then begin
                    empty_string:=false;
                    exit;
          end;
     end;
     empty_string:=true;
end;

function find_string_integer(var string_integer: integer; this_string : string; var start_point : integer) : boolean;
var pos, temp_int : integer;
    counting,found,negative : boolean;
begin
     if start_point>length(this_string) then
     begin
          find_string_integer:=false;
          exit;
     end;
     temp_int:=0;
     pos:=start_point-1;
     found:=false;
     counting:=false;
     negative:=false;
     repeat
           inc(pos);
           if (this_string[pos]>='0') and (this_string[pos]<='9') then
           begin
                counting:=true;
                temp_int:=temp_int*10+(ord(this_string[pos])-48);
           end
           else
           begin
                if (this_string[pos]='-') then
                begin
                     if not(counting) and ((this_string[pos+1]>='0') and (this_string[pos]<='9')) then
                     begin
                          counting:=true;
                          negative:=true;
                     end;
                end
                else if counting then found:=true;
           end;
     until (pos=length(this_string)) or found;
     if ((pos=length(this_string)) and counting and not(found)) then
     begin
          found:=true;
          pos:=pos+1;
     end;
     start_point:=pos;
     if found then
        if not(negative) then string_integer:=temp_int else string_integer:=-1*temp_int;
     find_string_integer:=found;
end;

function find_string_real(var string_real: real; this_string : string; var start_point : integer) : boolean;
var old_count, int1, int2, power_count, power : integer;
    junk : boolean;
begin
     if not(find_string_integer(int1,this_string,start_point)) then
     begin
          find_string_real:=false;
          exit;
     end;
     if (((start_point+1)>length(this_string)) or (this_string[start_point]<>'.')) then
     begin
          string_real:=int1;
          find_string_real:=true;
          exit;
     end;
     if ((this_string[start_point]='.') { and ((this_string[start_point+1]>='0') and (this_string[start_point+1]<='9'))} )
     then begin
               old_count:=start_point;
               junk:=find_string_integer(int2,this_string,start_point);
     end;
     power:=1;
     for power_count:=(old_count+2) to start_point do power:=power*10;
     if int1>0 then string_real:=int1+(int2/power)
               else string_real:=int1-(int2/power);
     find_string_real:=true;
end;

function hex_to_dec(char_in : char) : integer;
begin
     if ((char_in>='0') and (char_in<='9')) then
     begin
          hex_to_dec:=ord(char_in)-48;
          exit;
     end;
     if ((char_in>='a') and (char_in<='f')) then
     begin
          hex_to_dec:=ord(char_in)-87;
          exit;
     end;
     if ((char_in>='A') and (char_in<='F')) then
     begin
          hex_to_dec:=ord(char_in)-55;
          exit;
     end;
     writeln('Error - not a valid hex number!');
     halt;
end;


procedure read_face_data(var face_type, face_hue : word; var face_brightness : real);
var temp_char : char;
    temp_int : integer;
begin
     count:=1;
     while ((count<(length(temp_string)-5)) and (temp_string[count]<>'0')) do inc(count);
     if (count<(length(temp_string)-5)) and (temp_string[count+1]='x') then
     begin
          face_type:=ord(temp_string[count+2])-48;
          if face_type=8 then
          begin
               writeln('Warning - a user defined surface has been encountered!');
               writeln('          The surface has been redefined as colour 0, brightness 1');
               face_hue:=0;
          end
          else
          begin
               if ((face_type<0) or (face_type>3)) then
               begin
                    writeln('Error - type is outside range 0 to 3!');
                    halt;
               end;
               face_hue:=hex_to_dec(temp_string[count+3]);
          end;
          temp_int:=(hex_to_dec(temp_string[count+4])*16+hex_to_dec(temp_string[count+5]));
          if face_type=0 then
          begin
               if (face_hue=0) then
               begin
                    face_hue:=temp_int div 16;
                    face_brightness:=(temp_int mod 16)/15;
               end
               else
                   face_brightness:=temp_int/255;
          end
          else
              if face_type=1 then
                  face_brightness:=temp_int/255
              else
                  face_brightness:=1;
          count:=count+6;
     end
     else
     begin
          count:=1;
          if not(find_string_integer(temp_int,temp_string,count)) then
          begin
               writeln('Error! - Can''t find face data');
               halt;
          end;
          face_type:=temp_int DIV 4096;
          temp_int:=temp_int MOD 4096;
          face_hue:=temp_int DIV 256;
          temp_int:=temp_int MOD 256;
          if face_type=8 then
          begin
               writeln('Warning - a user defined surface has been encountered!');
               writeln('          The surface has been redefined as colour 0, brightness 1');
               face_hue:=0;
          end
          else
          begin
               if ((face_type<0) or (face_type>3)) then
               begin
                    writeln('Error - type is outside range 0 to 3!');
                    halt;
               end;
          end;
          if face_type=0 then
          begin
               if (face_hue=0) then
               begin
                    face_hue:=temp_int div 16;
                    face_brightness:=(temp_int mod 16)/15;
               end
               else
                   face_brightness:=temp_int/255;
          end
          else
              if face_type=1 then
                  face_brightness:=temp_int/255
              else
                  face_brightness:=1;
     end;
end;

procedure initial_data;
begin
     count:=1;
     if not(find_string_integer(vertices,temp_string,count)) then
     begin
          writeln('Error - can''t find number of vertices!');
          halt;
     end;
     if not(find_string_integer(faces,temp_string,count)) then
     begin
          writeln('Error - can''t find number of faces!');
          halt;
     end;
     if (find_string_integer(temp,temp_string,count)) then
     begin
          writeln('Error - too many numbers on PLG title line!');
          halt;
     end;
     writeln('Vertices = ',vertices,' : Faces = ',faces);
end;

procedure read_vertex;
begin
     count:=1;
     if not(find_string_real(vertex_x,temp_string,count)) then
     begin
          writeln('Error - can''t find x vertex!');
          halt;
     end;
     if not(find_string_real(vertex_y,temp_string,count)) then
     begin
          writeln('Error - can''t find y vertex!');
          halt;
     end;
     if not(find_string_real(vertex_z,temp_string,count)) then
     begin
          writeln('Error - can''t find z vertex!');
          halt;
     end;
     if (find_string_integer(temp,temp_string,count)) then
     begin
          writeln('Error - extra coordinate on vertex');
          halt;
     end;
end;


procedure read_face;
var f_type, f_hue : word;
    f_brightness : real;
    num_vertices, temp_count : integer;
    first_face_vertex, temp_face_vertex : plg_face_vertexptr;
begin
     count:=1;
     first_face_vertex:=nil;
     read_face_data(f_type, f_hue, f_brightness);
     if not(find_string_integer(num_vertices,temp_string,count)) then
     begin
          writeln('Error - can''t find number of vertices in face!');
          halt;
     end;
     if num_vertices=2 then writeln('Warning - a single line has been encountered!');
     if num_vertices=1 then writeln('Warning - a single point has been encountered!');
     writeln(fout,f_hue,' ',f_brightness : 2);
     writeln(fout,num_vertices);
     temp_count:=num_vertices;
     while temp_count>0 do
     begin
          if not(find_string_integer(temp,temp_string,count)) then
          begin
               writeln('Error - run out of face vertices!');
               halt;
          end;
          new(temp_face_vertex);
          temp_face_vertex^.vertex_num:=temp+1;
          temp_face_vertex^.next:=first_face_vertex;
          first_face_vertex:=temp_face_vertex;
          dec(temp_count);
     end;
{     if (find_string_integer(temp,temp_string,count)) then
     begin
          writeln(' = ',num_vertices,' Bad vertex = ',temp);
          writeln('Error - too many face vertices!');
          halt;
     end;
}     temp_face_vertex:=first_face_vertex;
     while temp_face_vertex<>nil do
     begin
          write(fout,temp_face_vertex^.vertex_num,'       ');
          temp_face_vertex:=temp_face_vertex^.next;
     end;
     writeln(fout);
     writeln(fout,0);
end;


begin
     mode:=1;  {1 = looking for initial info}
     write('PLG Input File : ');
     readln(input_file);
     writeln;
     write('3D Output File : ');
     readln(output_file);
     writeln;
     repeat
           write('Scale Factor : ');
           readln(scale);
           if scale<=0 then writeln('Error - scale must be greater than 0 - please re-enter');
     until scale>0;
     writeln;
     assign(fin,input_file);
     reset(fin);
     assign(fout,output_file);
     rewrite(fout);
     while (not(eof(fin) and (mode=4))) do
     begin
          readln(fin,temp_string);
          string_length:=length(temp_string);
          {Remove Comments}
          hash_pos:=pos('#',temp_string);
          if hash_pos<>0 then delete(temp_string,hash_pos,(string_length-hash_pos)+1);
          if not(empty_string(temp_string)) then
          begin
               if mode=1 then
               begin
                    initial_data;
                    writeln(fout,vertices);
                    if vertices=0 then
                    begin
                         writeln('Error - object has 0 vertices!');
                         halt;
                    end;
                    if faces=0 then
                    begin
                         writeln('Error - object has 0 faces!');
                         halt;
                    end;
                    mode:=2;
               end
               else
               if mode=2 then
               begin
                    read_vertex;
                    dec(vertices);
                    writeln(fout,vertex_x*scale,'       ',vertex_y*scale,'       ',vertex_z*scale);
                    if vertices=0 then
                    begin
                         mode:=3;
                         writeln(fout,0);
                         writeln(fout,faces);
                    end;
               end
               else
               if mode=3 then
               begin
                    read_face;
                    dec(faces);
                    if faces=0 then mode:=4;
               end;
          end;
     end;
     writeln(fout,0);
     close(fout);
     close(fin);
     if mode<>4 then writeln('Error - file finished prematurely!');
end.