Initial commit of 1992 raytracing code

turbo-pascal/ray7.pas

@@ -0,0 +1,265 @@
+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;
+
+procedure Save(var u: Universe; st: String);
+var
+  x,y: Integer;
+  c: LongInt;
+  r,g,b: Integer;
+begin
+  StartTga(st);
+  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;
+  EndTga;
+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;
+
+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;
+  Mandel = object(Plane)
+    function GetColor(aray: Ray; time: Real): LongInt; virtual;
+  end;
+
+function Mandel.GetColor(aray: Ray; time: Real): LongInt;
+const
+  k = 200;
+var
+  x,y,cRe,cIm: Real;
+  zRe,zIm,zx: Real;
+  Zsize: Real;
+  Count: integer;
+begin
+  y := (time * aray.dz + aray.oz)-50;
+  x := (time * aray.dx + aray.ox);
+  cRe := x/10; cIm := y/10;
+  zRe := 0; zIm := 0; zSize := 0;
+  Count := 0;
+  while (Count < k) and (Zsize < 2.0) do begin
+    zx  := zRe * zRe - zIm * zIm;
+    zIm := zRe * zIm - zIm * zRe;
+    zRe := zx;
+    zRe := zRe + cRe;
+    zIm := zIm + cIm;
+    Zsize := sqr(ZRe) + sqr(ZIm);
+    Inc(Count);
+  end;
+  if Count = k then
+    GetColor := $404040
+  else begin
+    Count := LongInt(Count)*360 div (k div 2);
+    GetColor := GetHsv(Count,100,100);
+  end;
+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 TraceIt;
+var
+  u: Universe;
+  m: Mandel;
+  p: Plane;
+begin
+  u.Init(320,200);
+  m.Init(0,-8,0, 0,1,0);
+  p.Init(0,-8,0, 0,1,0);
+  u.Insert(@m);
+  {Save(u,'brion3.tga');}
+  Qwik(u);
+  Beep;
+  u.Done;
+end;
+
+begin
+  Set13h;
+  SetUpRgb;
+  TraceIt;
+  ReadKey;
+  BiosMode(3);
+end.