program mmmmmmmmmmmmm;
{$X+}
uses Crt,Vga13h,RayTrace;

{ 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;

type
  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;
  Sky = object(Plane)
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
  end;

function Sky.GetColor(aray: Ray; time: Real): LongInt;
var
  x,y: Real;
  r,g,b: Integer;
begin
  x := (time * aray.dz + aray.oz);
  y := (time * aray.dx + aray.ox);

  GetColor := GetRgb(r,g,b);
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;

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;

procedure TraceIt;
var
  u: Universe;
  cs: array[0..7] of ColorSphere;
  s: Sky;
  i,j,k: Integer;
begin
  u.Init(320,200);
  s.Init(0,8,0, 0,1,0);
  u.Insert(@s);
  for i := 0 to 1 do
    for j := 0 to 3 do begin
      k := i*4+j;
      cs[k].Init(j*2-3,i*2-1,10,1,
        (k and 1) * 128,((k and 2) shr 1) * 128,
        ((k and 4) shr 2) * 128);
      u.Insert(@cs[k]);
    end;
  Zoom(u);
  Beep;
  u.Done;
end;

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