program mmmmmmmmmmmmm;
{$X+}
uses Crt,Vga13h,RayTrace,Dos;
{$I BufrFile.Inc}

type
  TgaHeader = record { 18 bytes total }
    who_knows: array[1..12] of Byte;
    Width: Word;
    Height: Word;
    BitsPerPixel: Byte;
    who_knows2: Byte;
  end;

const
  DefaultHeader: TgaHeader = (
    who_knows: (0, 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0);
    Width: 320;
    Height: 200;
    BitsPerPixel: 24;
    who_knows2: 32
  );

var
  tf: File of Byte;
  tff: File absolute tf;

procedure StartTga(s: String);
begin
  Assign(tf,s);
  Rewrite(tf);
  BlockWrite(tff,DefaultHeader,18);
end;

procedure EndTga;
begin
  Close(tf);
end;

procedure TgaDot(r,g,b: Integer);
begin
  if r > 255 then r := 255;
  if g > 255 then g := 255;
  if b > 255 then b := 255;
  if r < 0 then r := 0;
  if g < 0 then g := 0;
  if b < 0 then b := 0;
  Write(tf,Byte(b),Byte(g),Byte(r));
end;

{ r,g,b:0-255 }
function Rgb(r,g,b: Integer): Integer;
begin
  if r > 255 then r := 255;
  if g > 255 then g := 255;
  if b > 255 then b := 255;
  Rgb := (b shr 6) or ((g shr 3) and $1c) or (r and $e0);
end;

procedure RgbDot(x,y,r,g,b: Integer);
var
  r1,g1,b1,r2,g2,b2,c1,c2: Integer;
begin
  if r > 255 then r := 255;
  if g > 255 then g := 255;
  if b > 255 then b := 255;
  if r < 0 then r := 0;
  if g < 0 then g := 0;
  if b < 0 then b := 0;
  r1 := r and $e0; g1 := g and $e0; b1 := b and $c0;
  r2 := r1 + (r mod 32)+16;
  g2 := g1 + (g mod 32)+16;
  b2 := b1 + (b mod 64)+32;
  c1 := Rgb(r1,g1,b1); c2 := Rgb(r2,g2,b2);
  if (x mod 2) = (y mod 2) then PutPixel(x,y,c1) else PutPixel(x,y,c2);
end;

procedure SetUpRgb;
var
  Clrs: array[0..255,0..2] of Byte;
  i: Integer;
begin
  for i := 0 to 255 do begin
    Clrs[i,0] := (i and $e0) shr 2;
    Clrs[i,1] := (i and $1c) shl 1;
    Clrs[i,2] := (i and 3) shl 4;
    case Clrs[i,2] of
      15..31: Inc(Clrs[i,2],4);
      32..63: Inc(Clrs[i,2],8);
    end;
  end;
  SetColorBlock(0,256,Clrs);
end;

procedure Save(var u: Universe; st: String);
var
  x,y: Integer;
  c: LongInt;
  r,g,b: Integer;
begin
  StartTga(st);
  x := 0;
  for y := 0 to u.Height-1 do
    for x := 0 to u.Width-1 do begin
      c := u.TracePoint(x,y);
      r := (c and $ff0000) shr 16;
      g := (c and $ff00) shr 8;
      b := c and $ff;
      RgbDot(x,u.Height-1-y,r,g,b);
      TgaDot(r,g,b);
    end;
  EndTga;
end;

procedure Draw(var u: Universe);
var
  x,y: Integer;
  c: LongInt;
begin
  x := 0;
  while (x < u.Width) and (not KeyPressed) do begin
    for y := 0 to u.Height-1 do begin
      c := u.TracePoint(x,u.Height-1-y);
      if c <> 0 then
        RgbDot(x,y,(c and $ff0000) shr 16,(c and $ff00) shr 8,c and $ff);
    end;
    Inc(x);
  end;
end;

procedure Qwik(var u: Universe);
var
  x,y: Integer;
  c: LongInt;
  r,g,b: Byte;
begin
  x := 0;
  while (x < (u.Width div 2)) and (not KeyPressed) do begin
    for y := 0 to (u.Height div 2)-1 do begin
      c := u.TracePoint(x*2,u.Height-1-(y*2));
      if c <> 0 then begin
        r := (c and $ff0000) shr 16;
        g := (c and $ff00) shr 8;
        b := c and $ff;
        RgbDot(x*2,y*2,r,g,b); RgbDot(x*2+1,y*2,r,g,b);
        RgbDot(x*2+1,y*2+1,r,g,b); RgbDot(x*2,y*2+1,r,g,b);
      end;
    end;
    Inc(x);
  end;
end;

procedure Zoom(var u: Universe);
var
  x,y,i,j: Integer;
  c: LongInt;
  r,g,b: Byte;
begin
  x := 0;
  while (x < (u.Width div 4)) and (not KeyPressed) do begin
    for y := 0 to (u.Height div 4)-1 do begin
      c := u.TracePoint(x*4,u.Height-1-(y*4));
      if c <> 0 then begin
        r := (c and $ff0000) shr 16;
        g := (c and $ff00) shr 8;
        b := c and $ff;
        for i := 0 to 3 do
          for j := 0 to 3 do
            RgbDot(x*4+i,y*4+j,r,g,b);
      end;
    end;
    Inc(x);
  end;
end;

procedure Beep;
begin
  Sound(220);        { Beep }
  Delay(200);        { For 200 ms }
  NoSound;           { Relief! }
end;

type
   { Definition of the PCX file header }
   PCX_header = record
	       	pcx_id : byte;			{ Always $0A for PCX files }
		version : byte;			{ Version of the PCX format }
		encoding : byte;		{ 1 = RLE (RLL) compression }
		bpp : byte;			{ Number of bits per pixel }
		upleftx, uplefty : word;	{ position of upper left corner }
		lorightx, lorighty : word;	{ lower right corner (inclusive) }
		display_xres, display_yres : word; { resolution in dpi of display }
		palette : array [0..47] of byte; { palette data if it fits }
		reserved : byte;
		nplanes : byte;			{ number of bit planes of data }
		bytesperline : word;		{ # bytes in an uncompressed line }
		palletteinfo : word;
		reserved2 : array [0..57] of byte;
	       end;
  pplane = object(Plane)
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
  end;
  ColorSphere = object(Sphere)
    rc,gc,bc: Byte;
    constructor Init(x,y,z,r: Real; cr,cg,cb: Byte);
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
  end;
  arr_byte = array[0..65520] of byte;
  parr_byte = ^arr_byte;
  WoodSphere = object(Sphere)
    IsLoaded: Boolean;
    Width,Height: Integer;
    Buf: parr_byte;
    function GetPixel(x,y: Integer): Byte;
    constructor Init(x,y,z,r: Real; s: String);
    destructor Done; virtual;
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
  end;
  GraySphere = object(WoodSphere)
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
  end;

const
   { These two definitions are used to decompress data in the PCX file.
     (The compressed count byte has the top two bits set).              }

   PCX_COMPRESSED = $C0;
   PCX_MASK = $3F;

   Bits : array [0..7] of byte = (1, 2, 4, 8, 16, 32, 64, 128);

{ Read header of indicated PCX file.  Returns TRUE if OK, FALSE if error }

function pcx_read_header (var hdr : PCX_header; var f : buffered_file) : boolean;
var
   count : word;
   hdr_array : array [0..1] of char absolute hdr;
begin
   count := 0;
   while count < SizeOf(PCX_header) do
      begin
      hdr_array [count] := NextCharRead (f);
      Inc (count)
      end;
   pcx_read_header := (f.more_data) and (hdr.pcx_id = $0A);
end {pcx_read_header};

{ Read next line from PCX file into indicated array, up to indicated limit.
  Returns TRUE if data acquired, FALSE if error occurred.
  Note:  call pcx_read_header () first to begin reading file.              }

function pcx_next_line (var hdr : PCX_header; var f : buffered_file;
                        var line1; linesize : integer; var count : word) : boolean;
var
   line : array [0..1] of byte absolute line1;
   c : byte;
   len, len1 : integer;
   i, linebytes, b : word;
begin
   { initialize return value }
   pcx_next_line := FALSE;
   { determine number of bytes to acquire }
   linebytes := hdr.nplanes * hdr.bytesperline;
   { point to start of return data }
   count := 0;
   i := 0;
   while i < linebytes do
      begin
      { acquire next block of data }
      c := Ord (NextCharRead (f));
      if Not f.more_data
         then Exit;
      if (c AND PCX_COMPRESSED) = PCX_COMPRESSED
         then { acquire run-length encoded data }
              begin
              len := c AND PCX_MASK;
              c := Ord (NextCharRead (f));
              if Not f.more_data
                 then Exit;
              end
         else { acquire single byte }
              len := 1;
      { store block of data in array }
      len1 := len;
      if count + len1 > linesize
         then len1 := linesize - count;
      if count < linesize
         then begin
              FillChar (line [count], len1, c);
              Inc (count, len1);
              end;
      Inc (i, len);
      end;
   pcx_next_line := TRUE;
end {pcx_next_line};

constructor WoodSphere.Init(x,y,z,r: Real; s: String);
var
  PCXFile    : buffered_file;
  PCXBuf     : DiskFileBuffer;
  PCXLine    : array [0..2048] of byte;
  PCXHdr     : PCX_header;
  PCXWidth   : word;
  pixel_width: word;
  I, J       : integer;
  X1, Y1     : integer;
  found      : boolean;
  line_count : integer;
  clr        : byte;
  numlines: integer;
begin
  Sphere.Init(x,y,z,r);

  IsLoaded := False;
  if length(s) = 0 then Exit;
  { attempt to open file }
  AssignBufferedFile(PCXFile, s, @PCXBuf);
  OpenForBufferedRead(PCXFile, I);
  if I <> 0 then Exit;
  { read descriptive header }
  found := pcx_read_header (PCXHdr, PCXFile);
  if Not found then begin
    CloseForBufferedRead (PCXFile, I);
    Exit;
  end;
  IsLoaded := True;
  { display data }
  numlines := PCXHdr.lorighty - PCXHdr.uplefty + 1;
  pixel_width := PCXHdr.lorightx - PCXHdr.upleftx + 1;
  Width := pixel_width;
  Height := numlines;
  GetMem(Buf,Width*Height);
  line_count := 0;
  repeat
    found := pcx_next_line (PCXHdr, PCXFile,
                              PCXLine, SizeOf(PCXLine), PCXWidth);
    if found then begin
      for X1 := 0 to PCXWidth-1 do
        Buf^[(Height-1-line_count)*Width+X1] := PCXLine[X1];
      Inc (line_count);
    end;
  until (Not found) or (line_count = numlines);
  CloseForBufferedRead (PCXFile, I);
end;

destructor WoodSphere.Done;
begin
  if IsLoaded then
    FreeMem(Buf,Width*Height);
  Sphere.Done;
end;

function WoodSphere.GetPixel(x,y: Integer): Byte;
begin
  if IsLoaded and (x > 0) and (y > 0) and
    (x < Width) and (y < Height) then
    GetPixel := Buf^[y*Width+x]
  else
    GetPixel := 0;
end;

function WoodSphere.GetColor(aray: Ray; time: Real): LongInt;
var
  r: Ray;
  c: Integer;
begin
  r.ox := (aray.dx * time + aray.ox - xp + ra) / (ra*2);
  r.oy := (aray.dy * time + aray.oy - yp + ra) / (ra*2);
  r.oz := (aray.dz * time + aray.oz - zp + ra) / (ra*2);
  c := GetPixel(Round(r.ox*(Width-1)),Round(r.oy*(Height-1)));
  GetColor := GetRgb(c,c * 5 div 8,0);
end;

function GraySphere.GetColor(aray: Ray; time: Real): LongInt;
var
  r: Ray;
  c: Byte;
begin
  r.ox := (aray.dx * time + aray.ox - xp + ra) / (ra*2);
  r.oy := (aray.dy * time + aray.oy - yp + ra) / (ra*2);
  r.oz := (aray.dz * time + aray.oz - zp + ra) / (ra*2);
  c := GetPixel(Round(r.ox*(Width-1)),Round(r.oy*(Height-1)));
  GetColor := GetRgb(c,c,c);
end;

constructor ColorSphere.Init(x,y,z,r: Real; cr,cg,cb: Byte);
begin
  Sphere.Init(x,y,z,r);
  rc := cr; gc := cg; bc := cb;
end;

function ColorSphere.GetColor(aray: Ray; time: Real): LongInt;
var
  r: Ray;
  c: LongInt;
  cc: record b,g,r: Byte end absolute c;
begin
  ReflectRay(aray,time,r);
  c := Owner^.TraceRay(r);
  cc.r := Integer(cc.r) div 2 + rc;
  cc.g := Integer(cc.g) div 2 + gc;
  cc.b := Integer(cc.b) div 2 + bc;
  GetColor := c;
end;

function pplane.GetColor(aray: Ray; time: Real): LongInt;
var
  r: Ray;
  c: LongInt;
  cc: record b,g,r: Byte end absolute c;
begin
  ReflectRay(aray,time,r);
  c := Owner^.TraceRay(r);
  cc.r := Integer(cc.r) div 2 + 128;
  cc.g := Integer(cc.g) div 2 + 128;
  cc.b := Integer(cc.b) div 2 + 128;
  GetColor := c;
end;

procedure TraceIt;
var
  u: Universe;
  p: Pplane;
  wood: WoodSphere;
  mimas,earth: GraySphere;
begin
  u.Init(320,200);
  p.Init (0,-8,0, 0,1,0);
  wood.Init(-16,0,54,8, 'c:\brion\vga\wood2.pcx');
  mimas.Init(0,0,50,8, 'c:\brion\vga\mimas2.pcx');
  Earth.Init(16,0,54,8, 'c:\brion\vga\earth2.pcx');
  u.Insert(@wood);
  u.Insert(@mimas);
  u.Insert(@Earth);
  u.Insert(@p);
  Save(u,'brion5.tga');
  {Zoom(u);}
  Beep;
  wood.Done;
  Mimas.Done;
  Earth.Done;
  u.Done;
end;

begin
  Set13h;
  SetUpRgb;
  TraceIt;
  ReadKey;
  BiosMode(3);
end.