raytrace-retro/turbo-pascal/rayt5.pas

program RayTracingWithUltraRayTr;
{$X+}
uses Crt,Vga13h,RayTr,Dos;

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;
  ttf: File absolute tf;

procedure StartTga(s: String);
begin
  Assign(tf,s);
  Rewrite(tf);
  BlockWrite(ttf,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;
  if r < 0 then r := 0;
  if g < 0 then g := 0;
  if b < 0 then b := 0;
  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: TUniverse; st: String);
var
  x,y: Integer;
  c: RgbTriple;
  r,g,b: Integer;
begin
  StartTga(st);
  x := 0;
  for y := 0 to u.ScrHeight-1 do
    for x := 0 to u.ScrWidth-1 do begin
      u.TracePoint(x,y,c);
      r := Trunc(c.r*255);
      g := Trunc(c.g*255);
      b := Trunc(c.b*255);
      RgbDot(x,u.ScrHeight-1-y,r,g,b);
      TgaDot(r,g,b);
    end;
  EndTga;
end;

procedure Draw(var u: TUniverse);
var
  x,y: Integer;
  c: RgbTriple;
  r,g,b: Integer;
begin
  x := 0;
  while (x < u.ScrWidth) and (not KeyPressed) do begin
    for y := 0 to u.ScrHeight-1 do begin
      u.TracePoint(x,u.ScrHeight-1-y,c);
      r := Trunc(c.r*255);
      g := Trunc(c.g*255);
      b := Trunc(c.b*255);
      RgbDot(x,y,r,g,b);
    end;
    Inc(x);
  end;
end;

procedure Qwik(var u: TUniverse);
var
  x,y: Integer;
  c: RgbTriple;
  r,g,b: Integer;
begin
  x := 0;
  while (x < (u.ScrWidth div 2)) and (not KeyPressed) do begin
    for y := 0 to (u.ScrHeight div 2)-1 do begin
      u.TracePoint(x*2,u.ScrHeight-1-(y*2),c);
      r := Trunc(c.r*255);
      g := Trunc(c.g*255);
      b := Trunc(c.b*255);
      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;
    Inc(x);
  end;
end;

procedure Zoom(var u: TUniverse);
var
  x,y,i,j: Integer;
  c: RgbTriple;
  r,g,b: Integer;
begin
  x := 0;
  while (x < (u.ScrWidth div 4)) and (not KeyPressed) do begin
    for y := 0 to (u.ScrHeight div 4)-1 do begin
      u.TracePoint(x*4,u.ScrHeight-1-(y*4),c);
      r := Trunc(c.r*255);
      g := Trunc(c.g*255);
      b := Trunc(c.b*255);
      for i := 0 to 3 do
        for j := 0 to 3 do
          RgbDot(x*4+i,y*4+j,r,g,b);
    end;
    Inc(x);
  end;
end;

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

var
  Hour1,Minute1,Second1,Sec1001,
  Hour2,Minute2,Second2,Sec1002: Word;

procedure StartTime;
begin
  GetTime(Hour1, Minute1, Second1, Sec1001);
end;

procedure EndTime;
begin
  GetTime(Hour2, Minute2, Second2, Sec1002);
end;

function LeadingZero(w : Word) : String;
var
  s : String;
begin
  Str(w:0,s);
  if Length(s) = 1 then
    s := '0' + s;
  LeadingZero := s;
end;

procedure ShowTime;
var
  time1,time2,time3: Word;
begin
  Writeln('Starting time: ',Hour1,':',LeadingZero(Minute1));
  Writeln('Ending time: ',Hour2,':',LeadingZero(Minute2));
  time1 := Hour1*60+Minute1;
  time2 := Hour2*60+Minute2;
  time3 := time2-time1;
  Writeln('Total time: ',time3 div 60,':',LeadingZero(time3 mod 60));
end;

type
  PPillar = ^TCylinder;
  PFloor = ^TFloor;
  PCeiling = ^TCeiling;
  PMirrorSphere = ^TMirrorSphere;
  PPitInside = ^TPitInside;
  PBonfire = ^TBonfire;
  PFireCyl = ^TFireCyl;

  TPitInside = object(TCylinder)
    procedure GetInfo(Ray: TRay; var Inf: TRayInfo); virtual;
  end;
  TFloor = object(TPlane)
    procedure GetInfo(Ray: TRay; var Inf: TRayInfo); virtual;
  end;
  TCeiling = object(TPlane)
    procedure GetInfo(Ray: TRay; var Inf: TRayInfo); virtual;
  end;
  TMirrorSphere = object(TObject3d)
    Pos: TPoint3d;
    r: Float;
    constructor Init(x,y,z,ra: Float);
    procedure GetInfo(Ray: TRay; var Inf: TRayInfo); virtual;
  end;
  TBonfire = object(TSphere)
    procedure GetInfo(Ray: TRay; var Inf: TRayInfo); virtual;
  end;
  TFireCyl = object(TCylinder)
    procedure GetInfo(Ray: TRay; var Inf: TRayInfo); virtual;
  end;

procedure TFloor.GetInfo(Ray: TRay; var Inf: TRayInfo);
var
  d1,d2,d3: Float;
begin
  TPlane.GetInfo(Ray,Inf);
  if not Inf.Hit then Exit;
  d1 := Sqrt(Sqr(Inf.Pos.x)+Sqr(Inf.Pos.y)+Sqr(Inf.Pos.z-4));
  d2 := Sqrt(Sqr(Inf.Pos.x-3)+Sqr(Inf.Pos.y)+Sqr(Inf.Pos.z+7));
  d3 := Sqrt(Sqr(Inf.Pos.x+3)+Sqr(Inf.Pos.y)+Sqr(Inf.Pos.z+7));
  if ((d1 > 3) and (d1 < 5) and
    ((Inf.Pos.z > 4) or ((Inf.Pos.x < -1) or (Inf.Pos.x > 1)))) or
    (d2 < 2) or (d3 < 2) then
    Inf.Hit := False;
  MakeTrip(0,0,0,Inf.Reflectivity);
end;

procedure TCeiling.GetInfo(Ray: TRay; var Inf: TRayInfo);
begin
  TPlane.GetInfo(Ray,Inf);
  MakeTrip(0,0,0,Inf.Reflectivity);
  if (Inf.Pos.x < -9) or (Inf.Pos.x > 9) or
    (Inf.Pos.z < -10) or (Inf.Pos.z > 10) then
    Inf.Hit := False;
end;

constructor TMirrorSphere.Init(x,y,z,ra: Float);
begin
  TObject3d.Init;
  Pos.SetTo(x,y,z);
  r := ra;
end;

procedure TMirrorSphere.GetInfo(Ray: TRay; var Inf: TRayInfo);
var
  c,f: Float;
  p1,p2: TPoint3d;
begin
  GetSphereInfo(Ray,Pos,r,c,f);
  p1.SetTo(
    Ray.o.x+Ray.d.x*c,
    Ray.o.y+Ray.d.y*c,
    Ray.o.z+Ray.d.z*c);
  p2.SetTo(
    Ray.o.x+Ray.d.x*f,
    Ray.o.y+Ray.d.y*f,
    Ray.o.z+Ray.d.z*f);
  if (p1.z < Pos.z) or (p1.y < Pos.y) then c := -1;
  if (p2.z < Pos.z) or (p2.y < Pos.y) then f := -1;
  Inf.Hit := (c > 0.001) or (f > 0.001);
  if not Inf.Hit then Exit;
  Inf.Time := MaxReal;
  if c > 0.001 then Inf.Time := c;
  if (f < Inf.Time) and (f > 0.001) then Inf.Time := f;
  if Inf.Time = c then Inf.Pos := p1 else Inf.Pos := p2;
  Inf.Normal := Inf.Pos;
  Inf.Normal.Sub(Pos);
  Inf.GoingIn := (Inf.Normal.Dot(Ray.d)) < 0;
  if not Inf.GoingIn then begin
    Inf.Normal.Scale(-1);
    MakeTrip(0.75,0.75,0.75,Inf.Reflectivity);
    MakeTrip(0.25,0.25,0.25,Inf.Color);
    Inf.SpecularN := 200;
  end else begin
    MakeTrip(0,0,0,Inf.Reflectivity);
    MakeTrip(0.5,0.5,0.5,Inf.Color);
    Inf.SpecularN := 1;
  end;
  Inf.Brightness := 1;
  MakeTrip(1,1,1,Inf.Opacity);
end;

procedure TBonfire.GetInfo(Ray: TRay; var Inf: TRayInfo);
var
  z: Float;
begin
  TSphere.GetInfo(Ray,Inf);
  if not Inf.Hit then Exit;
  MakeTrip(0,0,0,Inf.Reflectivity);
  Inf.SpecularN := 50;
  if Inf.Pos.y < Pos.y then begin
    MakeTrip(1,1,1,Inf.Opacity);
    MakeTrip(0.8,0.8,0.8,Inf.Color);
    Inf.Brightness := 1;
  end else begin
    MakeTrip(0,0,0,Inf.Opacity);
    z := 1-((Inf.Pos.y-Pos.y)/r);
    MakeTrip(z,z*0.667,0,Inf.Color);
    Inf.Brightness := 0.3;
  end;
  Inf.IndexRefraction := 1;
end;

procedure TFireCyl.GetInfo(Ray: TRay; var Inf: TRayInfo);
var
  t,z: Float;
  r1: TRay;
begin
  TCylinder.GetInfo(Ray,Inf);
  if not Inf.Hit then Exit;
  Inf.Hit := ((Inf.Pos.z > 4) or ((Inf.Pos.x < -1) or (Inf.Pos.x > 1)));
  if not Inf.Hit then begin
    r1.o := Inf.Pos;
    r1.d := Ray.d;
    t := Inf.Time;
    GetInfo(r1,Inf);
    Inf.Time := Inf.Time + t;
  end else begin
    MakeTrip(0,0,0,Inf.Opacity);
    z := 1-((Inf.Pos.y-Pos.y)/h);
    MakeTrip(z,z*0.667,0,Inf.Color);
    Inf.Brightness := 0.5;
    Inf.IndexRefraction := 1;
  end;
end;

procedure TPitInside.GetInfo(Ray: TRay; var Inf: TRayInfo);
begin
  TCylinder.GetInfo(Ray,Inf);
  MakeTrip(0.8,0.8,0.8,Inf.Opacity);
end;

procedure TraceIt;
var
  u: TUniverse;
  l: PLightSource;
  o: PObject3d;
  i,j: Integer;
begin
  u.Init(320,200,10, 0,5,-20, 0,0,1, 0,1,0, 1, 40,30, 0.2,0.2,0.2, 0,0,0);
  u.Specular := False;

  u.InsertLight(New(PLightSource,Init(-3,0,-7, 6,4,0)));
  u.InsertLight(New(PLightSource,Init(3,0,-7, 6,4,0)));
  u.InsertLight(New(PLightSource,Init(75,50,100, 100,100,100)));
  u.InsertLight(New(PLightSource,Init(0,-20,4, 600,400,0)));
  u.Insert(New(PFloor,Init(0,0,0, 0,1,0)));
  u.Insert(New(PCeiling,Init(0,10,0, 0,1,0)));
  u.Insert(New(PMirrorSphere,Init(0,0,4, 3)));
  u.Insert(New(PBonfire,Init(-3,0,-7, 2)));
  u.Insert(New(PBonfire,Init(3,0,-7, 2)));
  u.Insert(New(PPitInside,Init(0,0,4, 0,-1,0, 3,10,0)));
  u.Insert(New(PPitInside,Init(0,0,4, 0,-1,0, 5,10,0)));
  u.Insert(New(PFireCyl,Init(0,-2,4, 0,1,0, 4,12,0)));
  for i := -2 to 2 do begin
    u.Insert(New(PPillar,Init(-7,0,i*4, 0,1,0, 1,10,0)));
    u.Insert(New(PPillar,Init(7,0,i*4, 0,1,0, 1,10,0)));
  end;
  Draw(u);
  {StartTime;
  Save(u,'brooke10.tga');
  EndTime;}
  Beep;
  u.Done;
end;

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