raytrace-retro/turbo-pascal/raypic.pas

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

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;

type
  GreenSphere = object(Sphere)
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
  end;
  RedSphere = object(Sphere)
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
  end;
  WhiteSphere = object(Sphere)
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
  end;
  Floor = object(Plane)
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
  end;
  WallA = object(Plane)
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
  end;
  WallB = object(Plane)
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
  end;
  Ceiling = object(Plane)
    function GetColor(aray: Ray; time: Real): LongInt; virtual;
  end;

function Floor.GetColor(aray: RAY; time: real): LongInt;
var
  x,y: Word;
begin
  x := Word(Round(time * aray.dz + aray.oz));
  y := Word(Round(time * aray.dx + aray.ox));
  GetColor := GetRgb(0,128+((x mod 2)+(y mod 2))*42,0);
end;

function Ceiling.GetColor(aray: RAY; time: real): LongInt;
var
  x,y: Word;
  c: Byte;
begin
  x := Word(Round(time * aray.dz + aray.oz));
  y := Word(Round(time * aray.dx + aray.ox));
  c := 128+((x mod 2)+(y mod 2))*42;
  GetColor := GetRgb(c,c,c);
end;

function WallA.GetColor(aray: RAY; time: real): LongInt;
var
  y: Word;
  c: Byte;
begin
  y := Word(Round(time * aray.dx + aray.ox));
  c := 128+(y mod 2)*42;
  GetColor := GetRgb(c,c div 2,0);
end;

function WallB.GetColor(aray: RAY; time: real): LongInt;
var
  x: Word;
  c: Byte;
begin
  x := Word(Round(time * aray.dz + aray.oz));
  c := 128+(x mod 2)*42;
  GetColor := GetRgb(c,c div 2,0);
end;

function GreenSphere.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;
  cc.g := Integer(cc.g) div 2 + 128;
  cc.b := Integer(cc.b) div 2;
  GetColor := c;
end;

function RedSphere.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;
  cc.b := Integer(cc.b) div 2;
  GetColor := c;
end;

function WhiteSphere.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 Draw(var u: Universe);
var
  x,y: Integer;
  c: LongInt;
  r,g,b: Integer;
begin
  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;
end;

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

procedure TraceIt;
var
  u: Universe;
  s: Sphere;
  rs: RedSphere;
  gs: GreenSphere;
  ws: WhiteSphere;
  fl: Floor;
  cl: Ceiling;
  w1,w4: WallA;
  w2,w3: WallB;
begin
  u.Init(320,200);

  s.Init(0,-8,30, 5);
  rs.Init(-10,-8,40, 5);
  gs.Init(10,-8,40, 5);
  ws.Init(-3,2,50, 6);

  fl.Init(-8,0,0, 0,1,0.001);
  cl.Init(8,0,0, 0,-1,0.001);
  w1.Init(0,0,50, 0,0,-1);
  w4.Init(0,0,-5, 0,0,1);
  w2.Init(0,-100,0, 2,0.25,0.001);
  w3.Init(0,-100,0, 2,-0.25,0.001);
  u.Insert(@fl);
  u.Insert(@cl);
  u.Insert(@w1);
  u.Insert(@w2);
  u.Insert(@w3);
  u.Insert(@w4);
  u.Insert(@s);
  u.Insert(@rs);
  u.Insert(@gs);
  u.Insert(@ws);
  Draw(u);
  Beep;
  u.Done;
end;

begin
  Set13h;
  SetUpRgb;
  StartTga('brooke1.tga');
  TraceIt;
  EndTga;
  ReadKey;
  BiosMode(3);
end.