{
***************************************************************************
*                                                                         *
* translate MTV fractint v18.2 ray trce image file to data                *
*                                                                         *
***************************************************************************
}
program f2b;

uses
  crt;

const
  inbuf_size          = 16384;
  DIM_FACTOR          = 1000;

type
  tpalette = array[0..255] of record
    r                 : byte;
    g                 : byte;
    b                 : byte;
  end;

  tpoint = record
    x                 : longint;
    y                 : longint;
    z                 : longint;
  end;

  tfacet = record
    colour            : byte;
    p1                : tpoint;
    p2                : tpoint;
    p3                : tpoint;
  end;

var
  infile              : text;
  outfile             : file;
  palfile             : file;
  wr                  : word;
  instr               : string[80];
  palette             : tpalette;
  palette_ptr         : word;
  facet               : tfacet;
  no_of_facets        : longint;

{
***************************************************************************
*                                                                         *
***************************************************************************
}
function dir_search(directive : char) : boolean;
begin
  dir_search := false;
  repeat
    readln(infile,instr);
  until (directive = instr[1]) or eof(infile);

  if not eof(infile) then
  begin
    if directive = instr[1] then
    begin
      dir_search := true;
    end;
  end;
end;

{
***************************************************************************
*                                                                         *
* returns index colour used for facet                                     *
*                                                                         *
***************************************************************************
}
const
  AND_FACTOR          = $f8;

function trans_f : byte;
var
  rv,gv,bv            : real;
  new_r,new_g,new_b   : byte;
  code                : word;
  x                   : word;
label done;
begin
  instr := copy(instr,pos(' ',instr) + 1,length(instr));
  val(copy(instr,1,6),rv,code);
  instr := copy(instr,pos(' ',instr) + 2,length(instr));
  val(copy(instr,1,6),gv,code);
  instr := copy(instr,pos(' ',instr) + 2,length(instr));
  val(copy(instr,1,6),bv,code);
  instr := copy(instr,pos(' ',instr) + 2,length(instr));

  new_r := trunc(rv * 64);
  new_g := trunc(gv * 64);
  new_b := trunc(bv * 64);

  for x := 0 to (palette_ptr - 1) do
  begin
    if (new_r and AND_FACTOR) = (palette[x].r and AND_FACTOR) then
    begin
      if (new_g and AND_FACTOR) = (palette[x].g and AND_FACTOR) then
      begin
        if (new_b and AND_FACTOR) = (palette[x].b and AND_FACTOR) then
        begin
          trans_f := x;
          goto done;
        end;
      end;
    end;
  end;
  palette[palette_ptr].r := new_r;
  palette[palette_ptr].g := new_g;
  palette[palette_ptr].b := new_b;
  trans_f := palette_ptr;
  inc(palette_ptr);
done:
end;

{
***************************************************************************
*                                                                         *
***************************************************************************
}
const
  DEC_FACTOR          = 0;

procedure trans_p(index : byte);
var
  code                : word;
  no_polys            : byte;
  temp_v              : real;

function get_v : longint;
begin
  instr := copy(instr,2,length(instr));
  val(copy(instr,1,7),temp_v,code);
  get_v := trunc(temp_v * DIM_FACTOR);
  instr := copy(instr,8,length(instr));
end;

begin
  instr := copy(instr,pos(' ',instr) + 1,length(instr));
  val(copy(instr,1,1),no_polys,code);

  if no_polys = 3 then
  begin
    facet.colour := index;

    gotoxy(1,1);

    readln(infile,instr);
    writeln(instr, '      ');

    facet.p1.x := get_v;
    facet.p1.y := get_v;
    facet.p1.z := get_v + DEC_FACTOR;

    readln(infile,instr);
    writeln(instr, '      ');
    facet.p2.x := get_v;
    facet.p2.y := get_v;
    facet.p2.z := get_v + DEC_FACTOR;

    readln(infile,instr);
    writeln(instr, '      ');
    facet.p3.x := get_v;
    facet.p3.y := get_v;
    facet.p3.z := get_v + DEC_FACTOR;

    writeln;
    writeln('No:',no_of_facets);
    writeln;

    writeln('X1:',facet.p1.x, '    ');
    writeln('Y1:',facet.p1.y, '    ');
    writeln('Z1:',facet.p1.z, '    ');

    writeln('X2:',facet.p2.x, '    ');
    writeln('Y2:',facet.p2.y, '    ');
    writeln('Z2:',facet.p2.z, '    ');

    writeln('X3:',facet.p3.x, '    ');
    writeln('Y3:',facet.p3.y, '    ');
    writeln('Z3:',facet.p3.z, '    ');
{    readkey;}

    inc(no_of_facets);

    blockwrite(outfile,facet,sizeof(facet),wr);
  end;
end;

{
***************************************************************************
*                                                                         *
***************************************************************************
}
procedure translate_fractfile;
var
  x                   : word;
begin
  palette_ptr := 1;
  no_of_facets := 0;
  for x := 0 to 255 do
  begin
    palette[x].r := 0;
    palette[x].g := 0;
    palette[x].b := 0;
  end;

  blockwrite(outfile,no_of_facets,sizeof(no_of_facets),wr);  {write header}

  repeat
    if dir_search('f') then
    begin
      x := trans_f;
      if dir_search('p') then
      begin
        trans_p(x);
      end;
    end;
  until eof(infile);

  seek(outfile,0);
  blockwrite(outfile,no_of_facets,sizeof(no_of_facets),wr);  {rewrite header}
end;

{
***************************************************************************
*                                                                         *
***************************************************************************
}
begin
  clrscr;
  assign(infile,'\tmp\fract005.ray');
  reset(infile);
  if ioresult = 0 then
  begin
    assign(outfile,'fract005.sr3');
    rewrite(outfile,1);
    if ioresult = 0 then
    begin
      translate_fractfile;
      close(outfile);

      assign(outfile,'pal.bin');
      rewrite(outfile,1);
      blockwrite(outfile,palette,sizeof(palette),wr);
      close(outfile);
    end
    else
    begin
      writeln('error writing file.');
    end;
    close(infile);
  end
  else
  begin
    writeln('error loading file.');
  end;
end.