{ RAYTRACE.PAS }
{ Ray-tracing unit, generic. (with shading) }

unit RayShade;

interface
uses Objects;
{ Base objects on Turbo Vision's TObject to make them useable on
  Turbo Vision streams. }

type
  VECTOR = object
    dx, dy, dz: real; { Three dimensional vector }
  end;
  RAY = object
    dx, dy, dz: real; { Direction vector }
    ox, oy, oz: real; { Origin }
    constructor Init (x, y, z, vx, vy, vz: real);
  end;

  PObj3d = ^Obj3d;
  PLightSource = ^LightSource;
  PUniverse = ^Universe;

  LightSource = object(TObject)
    Owner: PUniverse;
    xp,yp,zp: Real;
    br,bg,bb: Real;
    constructor Init(x,y,z,r,g,b: Real);
  end;

  Obj3d = object(TObject)
    Owner: PUniverse;
    xp,yp,zp: Real;
    refl: Real;
    constructor Init(x,y,z,r: Real);
    function Intersect(aray: RAY): Real; virtual;
    procedure SurfNormal(aray: Ray; time: Real; var oray: Ray); virtual;
    procedure ReflectRay(aray: Ray; time: Real; var oray: Ray); virtual;
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
    function Shade(aray: Ray; time: Real; c: LongInt): LongInt; virtual;
  end;
  PLANE = object(Obj3d)
    nx, ny, nz: real; { Vector normal (perpendicular) to plane }
    constructor Init(x, y, z, vx, vy, vz: real);
    function Intersect(aray: RAY): real; virtual;
    procedure SurfNormal(aray: Ray; time: Real; var oray: Ray); virtual;
    function GetColor(aray: RAY; time: Real): LongInt; virtual;
  end;
  SPHERE = object(Obj3d)
    ra,r2: real; { Radius squared }
    constructor Init(x, y, z, r: real);
    function Intersect(aray: RAY): real; virtual;
    procedure SurfNormal(aray: Ray; time: Real; var oray: Ray); virtual;
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
  end;

  Cylinder = object(Obj3d)
    { xp,yp,zp = center of bottom circle
      x2,y2,z2 = center of top circle
      ra = radius }
    x2,y2,z2,ra,r2: Real;
    constructor Init(x,y,z,xb,yb,zb,r: Real);
    function Intersect(aray: RAY): real; virtual;
    procedure SurfNormal(aray: Ray; time: Real; var oray: Ray); virtual;
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
  end;

  PlanePnt = object(Plane)
    xb,yb,zb,xc,yc,zc: Real;
    constructor Init(x1,y1,z1,x2,y2,z2,x3,y3,z3: Real);
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
  end;

  Universe = object(TObject)
    Width,Height: Integer;
    ar,ag,ab: Real; { Ambient lighting }
    Items,Lights: TCollection;
    constructor Init(aWidth,aHeight: Integer; r,g,b: Real);
    destructor Done; virtual;
    procedure Insert(o: PObj3d);
    procedure Delete(o: PObj3d);
    procedure InsertLight(l: PLightSource);
    procedure DeleteLight(l: PLightSource);
    procedure DeleteAll;
    function RayColor(aray: Ray): LongInt;
    function TraceRay(aray: Ray; var ob: PObj3d): Real;
    function TracePoint(x,y: Integer): LongInt;
  end;


{ LongInt: $00rrggbb }
procedure SepLong(c: LongInt; var r,g,b: Integer);
function GetRgb(r,g,b: Integer): LongInt;
function GetHsv(h,s,v: Integer): LongInt;
procedure Hsv2Rgb(h,s,v: Integer; var r,g,b: Integer);

implementation

procedure SepLong(c: LongInt; var r,g,b: Integer);
begin
  r := (c and $ff0000) shr 16;
  g := (c and $ff00) shr 8;
  b := c and $ff;
end;

procedure Hsv2Rgb(h,s,v: Integer; var r,g,b: Integer);
var
  rr,gg,bb,f,p1,p2,p3: Integer;
begin
  while h > 359 do Dec(h,360);
  while h < 0 do Inc(h,360);
  if s < 0 then s := 0;
  if s > 100 then s := 100;
  if v < 0 then v := 0;
  if v > 100 then v := 100;

  f := (h mod 60) * 5 div 3;
  h := h div 60;
  p1 := v*(100-s) div 625 * 16;
  p2 := v*(100-(s*f div 100)) div 625 * 16;
  p3 := v*(100-(s*(100-f) div 100)) div 625 * 16;
  v := v * 64 div 25;
  case h of
    0: begin r := v; g := p3; b := p1; end;
    1: begin r := p2; g := v; b := p1; end;
    2: begin r := p1; g := v; b := p3; end;
    3: begin r := p1; g := p2; b := v; end;
    4: begin r := p3; g := p1; b := v; end;
    5: begin r := v; g := p1; b := p2; end;
  end;
end;

function GetHsv(h,s,v: Integer): LongInt;
var r,g,b: Integer;
begin
  Hsv2Rgb(h,s,v,r,g,b);
  asm
    mov al,byte ptr [b]
    mov byte ptr [@Result],al
    mov al,byte ptr [g]
    mov byte ptr [@Result+1],al
    mov al,byte ptr [r]
    mov byte ptr [@Result+2],al
    mov byte ptr [@Result+3],0
  end;
end;

function GetRgb(r,g,b: Integer): LongInt;
begin
  if r > 255 then r := 255;
  if r < 0 then r := 0;
  if g > 255 then g := 255;
  if g < 0 then g := 0;
  if b > 255 then b := 255;
  if b < 0 then b := 0;
  asm
    mov al,byte ptr [b]
    mov byte ptr [@Result],al
    mov al,byte ptr [g]
    mov byte ptr [@Result+1],al
    mov al,byte ptr [r]
    mov byte ptr [@Result+2],al
    mov byte ptr [@Result+3],0
  end;
end;

constructor LightSource.Init(x,y,z,r,g,b: Real);
begin
  TObject.Init;
  xp := x; yp := y; zp := z;
  br := r; bg := g; bb := b;
end;

constructor Obj3d.Init(x,y,z,r: Real);
begin
  TObject.Init;
  xp := x; yp := y; zp := z; refl := r;
end;

function Obj3d.Intersect(aray: RAY): Real;
begin
  { 0 or neg = no intersect }
  Intersect := 0;
end;

procedure Obj3d.SurfNormal(aray: Ray; time: Real; var oray: Ray);
begin
  { No intersect, will never get called here }
end;

procedure Obj3d.ReflectRay(aray: RAY; time: real; var oray: RAY);
var
  normal: Ray;                    { Used for readability      }
  ndotn: real;                    { Used for readability      }
  idotn: real;                    { Used for readability      }
  idotn_div_ndotn_x2: real;       { Used for optimization     }
begin
  oray.ox := aray.dx * time + aray.ox; { Find the point of     }
  oray.oy := aray.dy * time + aray.oy; { intersection between  }
  oray.oz := aray.dz * time + aray.oz; { iray and sphere.      }
  SurfNormal(aray,time,normal);

  ndotn := (normal.dx * normal.dx +
	    normal.dy * normal.dy +
	    normal.dz * normal.dz);
  idotn := (normal.dx * aray.dx +
	    normal.dy * aray.dy +
	    normal.dz * aray.dz);
  idotn_div_ndotn_x2 := (2.0 * (idotn) / ndotn);

  oray.dx := aray.dx - idotn_div_ndotn_x2 * normal.dx;
  oray.dy := aray.dy - idotn_div_ndotn_x2 * normal.dy;
  oray.dz := aray.dz - idotn_div_ndotn_x2 * normal.dz;
end;

function Obj3d.GetColor(aray: Ray; time: Real): LongInt;
begin
  { See SurfNormal }
end;

function Obj3d.Shade(aray: Ray; time: Real; c: LongInt): LongInt;
var
  pl: PLightSource;
  ob: PObj3d;
  costheta,t,d,Ir,Ig,Ib: Real;
  l,n: Ray;
  i: Integer;
  cc: record b,g,r: Byte end absolute c;
begin
  l.ox := aray.dx*time+aray.ox;
  l.oy := aray.dy*time+aray.oy;
  l.oz := aray.dz*time+aray.oz;
  SurfNormal(aray,time,n);
  d := Sqrt(Sqr(n.dx)+Sqr(n.dy)+Sqr(n.dz));
  if d <> 0 then begin
    n.dx := n.dx / d;
    n.dy := n.dy / d;
    n.dz := n.dz / d;
  end;
  Ir := refl * Owner^.ar;
  Ig := refl * Owner^.ag;
  Ib := refl * Owner^.ab;
  for i := 0 to Owner^.Lights.Count-1 do begin
    pl := PLightSource(Owner^.Lights.At(i));
    l.dx := pl^.xp-(time*aray.dx+aray.ox);
    l.dy := pl^.yp-(time*aray.dy+aray.oy);
    l.dz := pl^.zp-(time*aray.dz+aray.oz);
    d := Sqrt(Sqr(l.dx)+Sqr(l.dy)+Sqr(l.dz));
    if d <> 0 then begin
      l.dx := l.dx / d;
      l.dy := l.dy / d;
      l.dz := l.dz / d;
    end;
    costheta := (n.dx*l.dx + n.dy*l.dy + n.dz*l.dz);
    t := Owner^.TraceRay(l,ob);
    if (costheta > 0) and ((t >= d) or (t < 0.001)) then begin
      Ir := Ir + ((refl * pl^.br) / (d + 0.001)) * costheta;
      Ig := Ig + ((refl * pl^.bg) / (d + 0.001)) * costheta;
      Ib := Ib + ((refl * pl^.bb) / (d + 0.001)) * costheta;
    end;
  end;
  Shade := GetRgb(
    Integer(cc.r)-128+Round(Ir),
    Integer(cc.g)-128+Round(Ig),
    Integer(cc.b)-128+Round(Ib));
end;


constructor RAY.Init(x, y, z, vx, vy, vz: real);
begin
  ox := x;
  oy := y;
  oz := z;
  dx := vx;
  dy := vy;
  dz := vz;
end; { ----- End: RAY::RAY() ----- }

constructor SPHERE.Init(x, y, z, r: real);
begin
  Obj3d.Init(x,y,z,1);
  ra := r;
  r2 := r * r;
end; { ----- End: SPHERE::SPHERE() ----- }

function SPHERE.Intersect(aray: RAY): real;
var
  a, b, c, t1, t2, t3, close, farther: real;
begin
  a := aray.dx * aray.dx + aray.dy * aray.dy + aray.dz * aray.dz;
  close := -1.0;
  farther := -1.0;
  if a <> 0 then
     begin
     b := 2.0 * ((aray.ox - xp) * aray.dx
        + (aray.oy - yp) * aray.dy
        + (aray.oz - zp) * aray.dz);
     c := (aray.ox - xp) * (aray.ox - xp)
        + (aray.oy - yp) * (aray.oy - yp)
        + (aray.oz - zp) * (aray.oz - zp) - r2;
     t1 := b * b - 4.0 * a * c;
     if t1 > 0 then
	begin
	t2 := sqrt(t1);
	t3 := 2.0 * a;
	close := -(b + t2) / t3;
	farther := -(b - t2) / t3;
	end;
     end;
  if close < farther then Intersect := close else Intersect := farther;
{  Intersect := (double)((close < farther) ? close : farther);}
end; { ---- End: SPHERE::Intersect() ----- }

procedure Sphere.SurfNormal(aray: Ray; time: Real; var oray: Ray);
begin
  oray.ox := aray.dx * time + aray.ox; {  Find the point of    }
  oray.oy := aray.dy * time + aray.oy; { intersection between  }
  oray.oz := aray.dz * time + aray.oz; { aray and sphere.      }
  oray.dx := oray.ox - xp;             {  Find the ray normal  }
  oray.dy := oray.oy - yp;             { to the sphere at the  }
  oray.dz := oray.oz - zp;             { intersection point.   }
end;

function Sphere.GetColor(aray: Ray; time: Real): LongInt;
var
  r: Ray;
  c,c2: LongInt;
  cc: record b,g,r: Byte end absolute c;
  cc2: record b,g,r: Byte end absolute c2;
begin
  ReflectRay(aray,time,r);
  c := Owner^.RayColor(r);
  c2 := Shade(aray,time,GetRgb(0,0,128));
  cc.r := cc.r div 2 + cc2.r;
  cc.g := cc.g div 2 + cc2.g;
  cc.b := cc.b div 2 + cc2.b;
  GetColor := c;
end;

constructor PLANE.Init(x, y, z, vx, vy, vz: real);
begin
  Obj3d.Init(x,y,z,0.9);
  nx := vx;
  ny := vy;
  nz := vz;
end; { ----- End: PLANE::PLANE() ----- }

function PlanePattern(x, y: word): LongInt;
var
  r,g,b: Integer;
begin
  r := (((x+y) mod 8))*32;
  g := ((x mod 8) xor (y mod 8))*32;
  b := (((x * x + y * y) mod 8))*32;
  PlanePattern := GetRgb(r,g,b);
end; { ----- End: PlanePattern() ----- }


function PLANE.GetColor(aray: RAY; time: real): LongInt;
begin
  GetColor := Shade(aray,time,
    PlanePattern(Round(time * aray.dz + aray.oz),
                 Round(time * aray.dx + aray.ox)));
end; { ----- End: PLANE::Pattern() ----- }

function PLANE.Intersect(aray: RAY): real;
var
  p1, p2, p3: real;
begin
  p1 := xp * nx + yp * ny + zp * nz;
  p2 := aray.ox * nx + aray.oy * ny + aray.oz * nz;
  p3 := aray.dx * nx + aray.dy * ny + aray.dz * nz;
  if p3 = 0 then p3 := 0.001;
  Intersect := (p1-p2)/p3;
end; { ----- End: PLANE::Intersect() ----- }

procedure Plane.SurfNormal(aray: Ray; time: Real; var oray: Ray);
begin
  oray.dx := nx; oray.dy := ny; oray.dz := nz;
end;

constructor Cylinder.Init(x,y,z,xb,yb,zb,r: Real);
begin
  Obj3d.Init(x,y,z,0.9);
  x2 := xb; y2 := yb; z2 := zb;
  ra := r; r2 := Sqr(r);
end;

function Cylinder.Intersect(aray: RAY): real;
begin
  Intersect := 0;
end;

procedure Cylinder.SurfNormal(aray: Ray; time: Real; var oray: Ray);
begin
end;

function Cylinder.GetColor(aray: Ray; time: Real): LongInt;
begin
  GetColor := Shade(aray,time,$c0c0c0);
end;

constructor PlanePnt.Init(x1,y1,z1,x2,y2,z2,x3,y3,z3: Real);
var
  a,b,c,d: Real;
begin
  a := y1*(z2-z3)+y2*(z3-z1)+y3*(z1-z2);
  b := z1*(x2-x3)+z2*(x3-x1)+z3*(x1-x2);
  c := x1*(y2-y3)+x2*(y3-y1)+x3*(y1-y2);
  d := -x1*(y2*z3-y3*z2)-x2*(y3*z1-y1*z3)-x3*(y1*z2-y2*z1);
  Plane.Init(x1,y1,z1,a,b,c);
  xb := x2; yb := y2; zb := z2;
  xc := x3; yc := y3; zc := z3;
end;

function PlanePnt.GetColor(aray: Ray; time: Real): LongInt;
var
  d: Real;
  c: Integer;
begin
  {d := Sqrt(
    Sqr(time * aray.dx + aray.ox - xp) +
    Sqr(time * aray.dy + aray.oy - yp) +
    Sqr(time * aray.dz + aray.oz - zp));
  if d > 255.0 then d := 255.0;
  c := 255-Round(d);
  if c < 96 then c := 96;}
  GetColor := Shade(aray,time,$c0c0c0);{GetRgb(c,c,c)};
end;


constructor Universe.Init(aWidth,aHeight: Integer; r,g,b: Real);
begin
  TObject.Init;
  Width := aWidth; Height := aHeight;
  ar := r; ag := g; ab := b;
  Items.Init(5,5);
  Lights.Init(3,3);
end;

destructor Universe.Done;
begin
  Items.Done;
  Lights.Done;
  TObject.Done;
end;

procedure Universe.Insert(o: PObj3d);
begin
  Items.Insert(o);
  o^.Owner := @Self;
end;

procedure Universe.Delete(o: PObj3d);
begin
  Items.Delete(o);
  o^.Owner := nil;
end;

procedure Universe.InsertLight(l: PLightSource);
begin
  Lights.Insert(l);
  l^.Owner := @Self;
end;

procedure Universe.DeleteLight(l: PLightSource);
begin
  Lights.Delete(l);
  l^.Owner := nil;
end;

procedure Universe.DeleteAll;
begin
  Items.DeleteAll;
  Lights.DeleteAll;
end;

function Universe.RayColor(aray: Ray): LongInt;
var
  t: Real;
  o: PObj3d;
begin
  t := TraceRay(aray,o);
  if o = nil then
    RayColor := 0
  else
    RayColor := o^.GetColor(aray,t);
end;

function Universe.TraceRay(aray: Ray; var ob: PObj3d): Real;
type
  arr = array[0..1000] of Real;
  parr = ^arr;
var
  times: parr;
  i,j: Integer;
  max: Real;
 procedure TraceOne(o: PObj3d); far;
 begin
   times^[i] := o^.Intersect(aray);
   Inc(i);
 end;
begin
  GetMem(times,Items.Count*SizeOf(Real));
  i := 0;
  Items.ForEach(@TraceOne);
  max := 1.7e38; { darn big }
  j := -1;
  for i := 0 to Items.Count-1 do
    if (times^[i] < max) and (times^[i] > 0.001) then begin
      max := times^[i]; j := i;
    end;
  if j <> -1 then begin
    ob := Items.At(j);
    TraceRay := max;
  end else begin
    ob := nil;
    TraceRay := 0;
  end;
  FreeMem(Times,Items.Count*SizeOf(Real));
end;

function Universe.TracePoint(x,y: Integer): LongInt;
var
  r: Ray;
begin
  r.ox := 0; r.oy := 0; r.oz := 0;
  r.dx := (x - (Width / 2)) / Width;
  r.dy := (y - (Height / 2)) / Height * 0.75;
  r.dz := 1;
  TracePoint := RayColor(r);
end;

end.