[Back to EGAVGA SWAG index] [Back to Main SWAG index] [Original]
program SphereMap;
{Demo of approximate sphere mapping presented in stereoscopic 3D!}
{January 31/1995 by Wil Barath. Released to Public Domain}
Uses Hardware;
Const Size=90;
Wait:Word=Size*2;
Var
Flambe:Array[0..Size*size] of Byte;
Sec:Array[0..255] of byte;
Par:Array[0..255] of Byte;
const palette : array [1..768] of byte = (
8, 0, 0, 12, 0, 0, 17, 0, 0, 22, 0, 0,
27, 0, 0, 31, 0, 0, 36, 0, 0, 41, 0, 0,
45, 0, 0, 50, 0, 0, 54, 0, 0, 59, 0, 0,
64, 0, 0, 68, 0, 0, 73, 0, 0, 77, 0, 0,
82, 0, 0, 86, 0, 0, 90, 0, 0, 95, 0, 0,
99, 0, 0, 103, 0, 0, 108, 0, 0, 112, 0, 0,
116, 0, 0, 120, 0, 0, 124, 0, 0, 128, 0, 0,
132, 0, 0, 136, 0, 0, 140, 0, 0, 144, 0, 0,
148, 0, 0, 152, 0, 0, 155, 0, 0, 159, 0, 0,
162, 0, 0, 166, 0, 0, 169, 0, 0, 173, 0, 0,
176, 8, 0, 179, 12, 0, 182, 17, 0, 185, 22, 0,
188, 27, 0, 191, 31, 0, 194, 36, 0, 197, 41, 0,
200, 45, 0, 202, 50, 0, 205, 54, 0, 208, 59, 0,
210, 64, 0, 212, 68, 0, 215, 73, 0, 217, 77, 0,
219, 82, 0, 221, 86, 0, 223, 90, 0, 225, 95, 0,
226, 99, 0, 228, 103, 0, 230, 108, 0, 231, 112, 0,
233, 116, 0, 234, 120, 0, 235, 124, 0, 236, 128, 0,
237, 132, 0, 238, 136, 0, 239, 140, 8, 240, 144, 12,
241, 148, 17, 241, 152, 22, 242, 155, 27, 242, 159, 31,
243, 162, 36, 243, 166, 41, 243, 169, 45, 243, 173, 50,
243, 176, 54, 243, 179, 59, 243, 182, 64, 242, 185, 68,
242, 188, 73, 241, 191, 77, 241, 194, 82, 240, 197, 86,
239, 200, 90, 238, 202, 95, 237, 205, 99, 236, 208, 103,
235, 210, 108, 234, 212, 112, 233, 215, 116, 231, 217, 120,
230, 219, 124, 228, 221, 128, 227, 223, 132, 225, 225, 136,
223, 226, 140, 221, 228, 144, 219, 230, 148, 217, 231, 152,
215, 233, 155, 213, 234, 159, 210, 235, 162, 208, 236, 166,
205, 237, 169, 203, 238, 173, 200, 239, 176, 197, 240, 179,
195, 241, 182, 192, 241, 185, 189, 242, 188, 186, 242, 191,
183, 243, 194, 179, 243, 197, 176, 243, 200, 173, 243, 202,
170, 243, 205, 166, 243, 208, 163, 243, 210, 159, 242, 212,
155, 242, 215, 152, 241, 217, 148, 241, 219, 144, 240, 221,
22, 10, 120, 27, 10, 120, 32, 10, 120, 37, 10, 120,
41, 10, 120, 46, 10, 120, 51, 10, 120, 55, 10, 120,
60, 10, 120, 64, 10, 120, 69, 10, 120, 74, 10, 120,
78, 10, 120, 83, 10, 120, 87, 10, 120, 92, 10, 120,
96, 10, 120, 100, 10, 120, 105, 10, 120, 109, 10, 120,
113, 10, 120, 118, 10, 120, 122, 10, 120, 126, 10, 120,
130, 10, 120, 134, 10, 120, 138, 10, 120, 142, 10, 120,
146, 10, 120, 150, 10, 120, 154, 10, 120, 158, 10, 120,
162, 10, 120, 165, 10, 120, 169, 10, 120, 172, 10, 120,
176, 10, 120, 179, 10, 120, 183, 10, 120, 186, 18, 120,
189, 22, 120, 192, 27, 120, 195, 32, 120, 198, 37, 120,
201, 41, 120, 204, 46, 120, 207, 51, 120, 210, 55, 120,
212, 60, 120, 215, 64, 120, 218, 69, 120, 220, 74, 120,
222, 78, 120, 225, 83, 120, 227, 87, 120, 229, 92, 120,
231, 96, 120, 233, 100, 120, 235, 105, 120, 236, 109, 120,
238, 113, 120, 240, 118, 120, 241, 122, 120, 243, 126, 120,
244, 130, 120, 245, 134, 120, 246, 138, 120, 247, 142, 120,
248, 146, 120, 249, 150, 120, 250, 154, 120, 251, 158, 120,
251, 162, 120, 252, 165, 120, 252, 169, 120, 253, 172, 120,
253, 176, 120, 253, 179, 120, 253, 183, 120, 253, 186, 120,
253, 189, 120, 253, 192, 120, 252, 195, 120, 252, 198, 120,
251, 201, 120, 251, 204, 120, 250, 207, 120, 249, 210, 120,
248, 212, 120, 247, 215, 120, 246, 218, 120, 245, 220, 120,
244, 222, 120, 243, 225, 120, 241, 227, 120, 240, 229, 120,
238, 231, 120, 237, 233, 120, 235, 235, 120, 233, 236, 120,
231, 238, 120, 229, 240, 120, 227, 241, 120, 225, 243, 120,
223, 244, 120, 220, 245, 120, 218, 246, 120, 215, 247, 120,
213, 248, 120, 210, 249, 120, 207, 250, 120, 205, 251, 120,
202, 251, 120, 199, 252, 120, 196, 252, 120, 193, 253, 120,
189, 253, 120, 186, 253, 120, 183, 253, 120, 180, 253, 120,
176, 253, 120, 173, 253, 120, 169, 252, 120, 165, 252, 120,
162, 251, 120, 158, 251, 120, 154, 250, 120, 32, 20, 120);
a:Word=$0123;
b:Word=$4567;
c:Word=$89ab;
Function Qrand:Word; Near ;Assembler;
asm
Mov ax,a { generate a pseudorandom }
Shl ax,1 { sequence to seed the base }
Adc ax,2904 { of our great pyre with }
Xor ax,$aaaa
Mov a,ax
Adc ax,b
Mov b,ax
Adc ax,c
Mov c,ax
end;
Function QRandom(n:Word):Word;near;assembler;
asm
call Qrand
Mul n
Mov ax,dx
end;
Procedure SetCGA256Clear;near;Assembler;
asm
CLD
mov ax,13h { AX:= 13h }
int 10h { Set Mode 13h (320x200x256)}
xor ax,ax { AX:= 0 }
mov cx,768 { CX:= # of palette entries }
mov dx,03C8h { DX:= VGA Port }
mov si,offset palette { SI:= palette[0] }
out dx,al { send zero to index port }
inc dx { inc to write port }
@l1:
mov bl,[si] { set palette entry }
shr bl,2 { divide by 4 }
mov [si],bl { save entry }
outsb { and write to port }
dec cx { CX:= CX - 1 }
jnz @l1 { if not done then loop }
mov ax,0a000h { AX:= segment of VGA base }
mov es,ax { ES:= AX }
mov di,0 { DI:= 0
}
mov cx,32000 { CX:= sizeof(Screen) div 2 }
xor ax,ax { AX:= 0
}
rep stosw { clear every byte on screen to zero }
end;
Procedure DoInferno;
Var p,d:Word;
Begin
If wait>0 then Dec(Wait) else
Begin
For p:=2 to Size*Pred(size) do
Begin
d:=Flambe[p]shl 1+Flambe[p+Pred(size)]+Flambe[p+Succ(size)]+
Flambe[p+Size]shl 2;
if d>0 then flambe[p-2]:=Pred(d) shr 3;
end;
d:=QRand AND $7f or $20;
For p:=Size*Pred(size) to Size*size do
Begin
If Qrand>$f000 then d:= QRand AND $7f or $20;
FLambe[p]:=d;
end;
end;
end;
procedure CalcCircle(r:Word);
var rr,xx,yy,x,y:Integer; {r *must* be <= 128}
begin
rr:=r;y:=0;x:=r;rr:=r*r;xx:=rr-x;yy:=0;
Repeat
Sec[r-y]:=x;
Sec[r-x]:=y;
Sec[r+x]:=y;
Sec[r+y]:=x; {chord lengths per sector}
if xx>(rr-yy) then
Begin
Inc(xx,1-x-x);dec(x);
end;
Inc(yy,y+y+1);inc(y);
Until x<y; {sneaky mix of secant and scaling}
For x:=0 to r do Par[x div 2]:=(x*2+sec[x]*3) div 5;
For x:=r to r+r do Par[x div 2]:=(r*6-sec[x]*3+x*2+3) div 5;
end;{}
Procedure SphereMap2(PMAP:Pointer;sx,sy,cx,cy,Shift:Word);
Type SNeaky = Record part1:Byte; Data:Word; Part2:Byte;End;
A = Array[0..64000] of Byte;
PA =^a;
Var loop:Integer;Width,Scale,Image:LongInt;p,x:Word;
Begin
Inc(LongInt(pMap),Shift);
For Loop:= 0 to sy do
Begin
Width:=Sec[Loop]+1;
Image:=0;
p:=(cy-sy shr 1 +Loop)*320+cx-width;
Inc(width,width);
scale:=sx;scale:=scale*128 div width;
For x:=p to p+width do
Begin
Mem[$a000:x]:=PA(PMap)^[Par[Sneaky(image).data]];
Inc(Image,Scale);
end;
Inc(Longint(pMap),sx);
end;
end;
Var lp:Integer;
Begin {Program}
SetCGA256Clear;
CalcCircle(Size Div 2);
For lp:=0 to size * size do Flambe[lp]:=(((lp div size) mod 10) + (lp mod
10))shl 2;
Repeat
DoInferno;
SphereMap2(@Flambe,Size,Size,100,100,size-(Wait Mod Size));
SphereMap2(@Flambe,Size,Size,220,100,size-(Wait Mod Size)-10);
until keypressed;
asm
mov ax,03h { AX := 3h }
int 10h { restore text mode }
end;
end.
[Back to EGAVGA SWAG index] [Back to Main SWAG index] [Original]