[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]
{
Voxel's in a litteral sence are "Volume Pixels" so to do it 100% correctly
you would have to draw a 3d rectangular box at each coord.
Fortunitely there is an easy way to make it MUCH faster with out loosing
much detail.
Here is a re-work of the voxel code posted earlier. I have renamed
everything so it would be easier to follow. I have also added color
interpolation when drawing it. I haven't played with it in a while (cause
I like to write all my own code), but I'm sure everything is in working
order.
}
Program VoxelLand; {$G+}
{ Alex Chalfin }
{ Yet another modified source of Voxels (I forget who posted it first) }
{ Added: Gouraud interpolation of the colors for a smoother look }
{ It might be a little faster. }
{ Internet: achalfin@uceng.uc.edu }
{ Fidonet: 1:108/180 }
Uses Crt;
Type MapArray = Array[0..65534] of Byte; ScreenArray=Array[0..63999] of Byte;
PMapArray = ^MapArray; PScreenArray = ^ScreenArray;
Var Map : PMapArray; VScreen : PScreenArray; Screen : PScreenArray;
Range : Array[0..319] of Byte;
Sine, Cosine : Array[0..511] of Integer;
Procedure InitGraph;
Begin Screen := Ptr($A000, 0); New(VScreen);
Asm; Mov ax,13h; Int 10h; End; End;
Procedure CloseGraph;
Begin Asm; Mov ax,3h; Int 10h; End; Dispose(VScreen); End;
Procedure ClearScreen(Var S); Assembler;
Asm; Les di,S; db 66h; Xor ax,ax; Mov cx,16000; db 66h; Rep Stosw; End;
Procedure CopyScreen(Var S, D); Assembler;
Asm; Push ds;Les di,D;Lds si,S;Mov cx,16000;db 66h;Rep Movsw;Pop ds; End;
Procedure SetColor(Color, R, G, B : Byte);
Begin Port[$3c8]:=Color;Port[$3c9]:=R;Port[$3c9]:=G;Port[$3c9]:=B;End;
Procedure InitPalette;
Var Count : Word;
Begin For Count := 1 to 25 do SetColor(Count, Count*2, Count*2, 63);
For Count := 25 to 127 do SetColor(Count, Count Div 3, Count Div 2, 0); End;
Function NewColor(Mc, N, Dvd : integer) : Byte;
Var Loc : Integer;
Begin Loc := (Mc + N - Random(N Shl 1)) Div Dvd - 1;
If Loc > 250 Then Loc := 250;
If Loc < 5 Then Loc:=5; NewColor := Lo(Loc); End;
Procedure MakeFractalMap(X1, Y1, X2, Y2 : Word);
Var Xn, Yn, Dxy, P1, P2, P3, P4 : Word;
Begin If ((x2-x1<2) and (y2-y1<2)) Then Exit;
P1:=Map^[(Y1 Shl 8)+X1]; P2:=Map^[(Y2 Shl 8)+X1]; P3:=Map^[(Y1 Shl 8)+X2];
P4:=Map^[(Y2 Shl 8)+X2]; Xn:=(X2+X1) Shr 1; Yn:=(Y2+Y1) Shr 1;
Dxy:=5 * (X2 - X1 + Y2 - Y1) Div 3;
If Map^[(Y1 Shl 8)+Xn]=0 Then Map^[(Y1 Shl 8)+Xn]:=NewColor(P1+P3,Dxy,2);
If Map^[(Yn Shl 8)+X1]=0 Then Map^[(Yn Shl 8)+X1]:=NewColor(P1+P2,Dxy,2);
If Map^[(Yn Shl 8)+X2]=0 Then Map^[(Yn Shl 8)+X2]:=NewColor(P3+P4,Dxy,2);
If Map^[(Y2 Shl 8)+Xn]=0 Then Map^[(Y2 Shl 8)+Xn]:=NewColor(P1+P2,Dxy,2);
Map^[(Yn Shl 8)+Xn] := NewColor(P1 + P2 + P3 + P4, Dxy, 4);
MakeFractalMap(X1, Y1, Xn, Yn); MakeFractalMap(Xn, Y1, X2, Yn);
MakeFractalMap(X1, Yn, Xn, Y2); MakeFractalMap(Xn, Yn, X2, Y2); End;
Procedure CreateMap;
Begin Randomize; New(Map); FillChar(Map^[0], (256*256)-1, 0);
Map^[0]:=128; Writeln('Generating map.'); MakeFractalMap(0,0,256,256); End;
Procedure MakeSinus;
Var Count : Word;
Begin For Count := 0 to 511 do Begin
Sine[Count] := Round(Sin(Count*((2*Pi)/512)) * 256);
Cosine[Count] := Round(Cos(Count*((2*Pi)/512)) * 256); End;End;
Procedure InterPollColor(Y, Y2, X, MapColor: Integer); Assembler;
Asm; Les di,VScreen; Mov ax,Y2;Cmp ax,199;Jl @GouraudColor;@FlatColor:
Mov bx,320;IMul bx;Add ax,X;Add di,ax; Mov cx,Y2;Sub cx,Y;Mov ax,MapColor
@FlatLooper:;Mov es:[di],al;Sub di,320;Dec cx;Jnz @FlatLooper;Jmp @Exit
@GouraudColor:;Mov cx,ax; Sub cx,Y;Mov bx,320;IMul bx;Add ax,X
Add di,ax;Mov ax,MapColor;Xor bx,bx;Mov bl,Byte Ptr es:[di+320]
Push bx;Sub ax,bx;Shl ax,8;Cwd;Idiv cx;Mov bx,ax;Pop ax;Shl ax,8
Shr cx,1;Jnc @Gouraud4Looper;Mov es:[di],ah;Add ax,bx;Sub di,320
Jcxz @Exit;@Gouraud4Looper:;Mov es:[di],ah;Add ax,bx;Sub di,320
Mov es:[di],ah;Add ax,bx;Sub di,320;Dec cx;Jnz @Gouraud4Looper;@Exit: End;
Procedure DisplayLandScape(XPos, YPos, Dir : Integer);
Const ScreenWidth = 320;
Var ViewerZ, YDepth, ColWidth,XCount, YCount, NewX, NewY : Integer;
ProjX, ProjY, ZPos, MapColor,BarCount, CrossCount : Integer;
LeftLine, RightLine,YSin, YCos : Integer;
Begin
FillChar(Range, 320, 199); ViewerZ := Map^[(YPos Shl 8)+XPos] + 100;
For YCount := YPos to (YPos + 50) do
Begin YDepth := ((YCount-YPos) Shl 1)+1; ColWidth:=(300 Div YDepth)+4;
LeftLine:=(XPos+(YPos-YCount));RightLine:=(XPos + (-YPos + YCount));
YSin := (YCount-YPos) * Sine[Dir];YCos := (YCount-YPos) * CoSine[Dir];
For XCount := LeftLine to RightLine do
Begin
NewX := ((XCount-XPos)*CoSine[Dir]+YSin) Shr 8 + XPos;
NewY := (YCos-(XCount-XPos)*Sine[Dir]) Shr 8 + YPos;
ProjX := ((XCount-XPos) * ScreenWidth) Div YDepth + 160;
If (ProjX >= 0) And ((ProjX + ColWidth) <= 319)
Then Begin
ZPos := Map^[(NewY Shl 8) + NewX]; MapColor := ZPos Shr 1;
If ZPos <= 50 Then ZPos := 50;
ProjY := ((ViewerZ - ZPos) Shl 5) Div YDepth + 100;
If (ProjY >= 0) And (ProjY <= 199)
Then Begin For BarCount := ProjX to (ProjX + ColWidth) do
Begin If ProjY < Range[BarCount] Then Begin
InterPollColor(ProjY, Range[BarCount], BarCount, MapColor);
Range[BarCount] := ProjY; End;End;End;End;End;End;End;
Function Voxelize : Real;
Var Time : Longint Absolute $0000:$046c; StartTime, EndTime, Frame : Longint;
XPos, YPos, Dir : Integer; Quit : Boolean;
Begin
InitGraph; InitPalette;Quit:=False;XPos:=0;YPos:=0;Dir:=0;StartTime:=Time;
Frame := 0;
Repeat
Dir := Dir And 511; Frame := Frame + 1;
ClearScreen(VScreen^); DisplayLandscape(XPos Shr 8, YPos Shr 8, Dir);
CopyScreen(VScreen^, Screen^);
If KeyPressed Then Begin
Case ReadKey of #0 : Case ReadKey of
#75 : Dir := Dir - 10; #77 : Dir := Dir + 10; { Right Key }
#72 : Begin XPos:=(XPos+Sine[Dir] Shl 2);
YPos := (YPos + CoSine[Dir] Shl 2); End;
#80 : Begin XPos := (XPos - Sine[Dir] Shl 2);
YPos := (YPos - CoSine[Dir] Shl 2); End;
End; #27 : Quit := True; End; End;
Until Quit; EndTime := Time; CloseGraph; Dispose(Map);
Voxelize := (Frame*18.2)/(EndTime-StartTime); End;
Begin
MakeSinus; CreateMap; Writeln(Voxelize:5:2, ' Frames per second');
End.
This one is a little longer (ok, alot), but it looks cool!
Alex
... I haven't lost my mind; it's backed up on tape somewhere!
___ Blue Wave/QWK v2.12
--- WILDMAIL!/WC v4.11
* Origin: Cormac mac Airt BBS - Cincinnati, OH (513) 731-4493 (1:108/180.0)
SEEN-BY: 108/50 155 180 220 325 396/1 3615/50 51
PATH: 108/180 220 3615/50
[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]