brooke/raytrace-retro
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Initial commit of 1992 raytracing code

Browse source
This commit is contained in:
Brooke Vibber 2026-04-08 20:43:13 -07:00
commit 3f46e7dd82
42 changed files with 8483 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

268
turbo-pascal/ray4b.pas Normal file
View file

@ -0,0 +1,268 @@
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
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;
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;
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;
TraceIt;
ReadKey;
BiosMode(3);
end.