home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / graphics.swg / 0169_Voxels.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1995-02-28  |  6.8 KB  |  161 lines
  1.  {
  2.  Voxel's in a litteral sence are "Volume Pixels" so to do it 100% correctly
  3.  you would have to draw a 3d rectangular box at each coord.
  4.  
  5.  Fortunitely there is an easy way to make it MUCH faster with out loosing
  6.  much detail.
  7.  
  8.  Here is a re-work of the voxel code posted earlier. I have renamed
  9.  everything so it would be easier to follow. I have also added color
  10.  interpolation when drawing it. I haven't played with it in a while (cause
  11.  I like to write all my own code), but I'm sure everything is in working
  12.  order.
  13. }
  14. Program VoxelLand; {$G+}
  15. { Alex Chalfin }
  16. { Yet another modified source of Voxels (I forget who posted it first) }
  17. { Added: Gouraud interpolation of the colors for a smoother look }
  18. {        It might be a little faster.                            }
  19. { Internet: achalfin@uceng.uc.edu }
  20. { Fidonet: 1:108/180              }
  21.  
  22. Uses Crt;
  23. Type MapArray = Array[0..65534] of Byte; ScreenArray=Array[0..63999] of Byte;
  24.   PMapArray = ^MapArray; PScreenArray = ^ScreenArray;
  25.  
  26. Var Map : PMapArray; VScreen : PScreenArray; Screen : PScreenArray;
  27.   Range : Array[0..319] of Byte;
  28.   Sine, Cosine : Array[0..511] of Integer;
  29.  
  30. Procedure InitGraph;
  31. Begin Screen := Ptr($A000, 0); New(VScreen);
  32. Asm; Mov  ax,13h; Int  10h; End; End;
  33.  
  34. Procedure CloseGraph;
  35. Begin Asm; Mov ax,3h; Int 10h; End; Dispose(VScreen); End;
  36.  
  37. Procedure ClearScreen(Var S); Assembler;
  38. Asm; Les di,S; db 66h; Xor ax,ax; Mov cx,16000; db 66h; Rep Stosw; End;
  39.  
  40. Procedure CopyScreen(Var S, D); Assembler;
  41. Asm; Push ds;Les di,D;Lds si,S;Mov cx,16000;db 66h;Rep Movsw;Pop  ds; End;
  42.  
  43. Procedure SetColor(Color, R, G, B : Byte);
  44. Begin Port[$3c8]:=Color;Port[$3c9]:=R;Port[$3c9]:=G;Port[$3c9]:=B;End;
  45.  
  46. Procedure InitPalette;
  47. Var Count : Word;
  48. Begin For Count := 1 to 25 do SetColor(Count, Count*2, Count*2, 63);
  49. For Count := 25 to 127 do SetColor(Count, Count Div 3, Count Div 2, 0); End;
  50.  
  51. Function NewColor(Mc, N, Dvd : integer) : Byte;
  52. Var Loc : Integer;
  53. Begin Loc := (Mc + N - Random(N Shl 1)) Div Dvd - 1;
  54.  If Loc > 250 Then Loc := 250;
  55.  If Loc < 5 Then Loc:=5; NewColor := Lo(Loc); End;
  56.  
  57. Procedure MakeFractalMap(X1, Y1, X2, Y2 : Word);
  58. Var Xn, Yn, Dxy, P1, P2, P3, P4 : Word;
  59. Begin If ((x2-x1<2) and (y2-y1<2)) Then Exit;
  60.  P1:=Map^[(Y1 Shl 8)+X1]; P2:=Map^[(Y2 Shl 8)+X1]; P3:=Map^[(Y1 Shl 8)+X2];
  61.  P4:=Map^[(Y2 Shl 8)+X2]; Xn:=(X2+X1) Shr 1; Yn:=(Y2+Y1) Shr 1;
  62.  Dxy:=5 * (X2 - X1 + Y2 - Y1) Div 3;
  63.  If Map^[(Y1 Shl 8)+Xn]=0 Then Map^[(Y1 Shl 8)+Xn]:=NewColor(P1+P3,Dxy,2);
  64.  If Map^[(Yn Shl 8)+X1]=0 Then Map^[(Yn Shl 8)+X1]:=NewColor(P1+P2,Dxy,2);
  65.  If Map^[(Yn Shl 8)+X2]=0 Then Map^[(Yn Shl 8)+X2]:=NewColor(P3+P4,Dxy,2);
  66.  If Map^[(Y2 Shl 8)+Xn]=0 Then Map^[(Y2 Shl 8)+Xn]:=NewColor(P1+P2,Dxy,2);
  67.  Map^[(Yn Shl 8)+Xn] := NewColor(P1 + P2 + P3 + P4, Dxy, 4);
  68.  MakeFractalMap(X1, Y1, Xn, Yn); MakeFractalMap(Xn, Y1, X2, Yn);
  69.  MakeFractalMap(X1, Yn, Xn, Y2); MakeFractalMap(Xn, Yn, X2, Y2); End;
  70.  
  71. Procedure CreateMap;
  72. Begin Randomize; New(Map); FillChar(Map^[0], (256*256)-1, 0);
  73.   Map^[0]:=128; Writeln('Generating map.'); MakeFractalMap(0,0,256,256); End;
  74.  
  75. Procedure MakeSinus;
  76. Var Count : Word;
  77. Begin For Count := 0 to 511 do Begin
  78. Sine[Count] := Round(Sin(Count*((2*Pi)/512)) * 256);
  79. Cosine[Count] := Round(Cos(Count*((2*Pi)/512)) * 256); End;End;
  80.  
  81. Procedure InterPollColor(Y, Y2, X, MapColor: Integer); Assembler;
  82. Asm; Les  di,VScreen; Mov  ax,Y2;Cmp  ax,199;Jl @GouraudColor;@FlatColor:
  83.   Mov bx,320;IMul bx;Add ax,X;Add di,ax;  Mov  cx,Y2;Sub  cx,Y;Mov  ax,MapColor
  84.  @FlatLooper:;Mov  es:[di],al;Sub  di,320;Dec  cx;Jnz @FlatLooper;Jmp @Exit
  85.  @GouraudColor:;Mov  cx,ax;  Sub  cx,Y;Mov  bx,320;IMul bx;Add  ax,X
  86.   Add di,ax;Mov  ax,MapColor;Xor  bx,bx;Mov  bl,Byte Ptr es:[di+320]
  87.   Push bx;Sub  ax,bx;Shl  ax,8;Cwd;Idiv cx;Mov  bx,ax;Pop  ax;Shl  ax,8
  88.   Shr cx,1;Jnc @Gouraud4Looper;Mov  es:[di],ah;Add  ax,bx;Sub  di,320
  89.   Jcxz @Exit;@Gouraud4Looper:;Mov  es:[di],ah;Add  ax,bx;Sub  di,320
  90.   Mov es:[di],ah;Add ax,bx;Sub di,320;Dec cx;Jnz @Gouraud4Looper;@Exit: End;
  91.  
  92. Procedure DisplayLandScape(XPos, YPos, Dir : Integer);
  93. Const ScreenWidth = 320;
  94. Var ViewerZ, YDepth, ColWidth,XCount, YCount, NewX, NewY : Integer;
  95.   ProjX, ProjY, ZPos, MapColor,BarCount, CrossCount : Integer;
  96.   LeftLine, RightLine,YSin, YCos : Integer;
  97.  
  98. Begin
  99.   FillChar(Range, 320, 199); ViewerZ := Map^[(YPos Shl 8)+XPos] + 100;
  100.   For YCount := YPos to (YPos + 50) do
  101.     Begin YDepth := ((YCount-YPos) Shl 1)+1; ColWidth:=(300 Div YDepth)+4;
  102.       LeftLine:=(XPos+(YPos-YCount));RightLine:=(XPos + (-YPos + YCount));
  103.       YSin := (YCount-YPos) * Sine[Dir];YCos := (YCount-YPos) * CoSine[Dir];
  104.       For XCount := LeftLine to RightLine do
  105.         Begin
  106.           NewX := ((XCount-XPos)*CoSine[Dir]+YSin) Shr 8 + XPos;
  107.           NewY := (YCos-(XCount-XPos)*Sine[Dir]) Shr 8 + YPos;
  108.           ProjX := ((XCount-XPos) * ScreenWidth) Div YDepth + 160;
  109.           If (ProjX >= 0) And ((ProjX + ColWidth) <= 319)
  110.             Then Begin
  111.               ZPos := Map^[(NewY Shl 8) + NewX]; MapColor := ZPos Shr 1;
  112.               If ZPos <= 50 Then ZPos := 50;
  113.               ProjY := ((ViewerZ - ZPos) Shl 5) Div YDepth + 100;
  114.               If (ProjY >= 0) And (ProjY <= 199)
  115.                 Then Begin For BarCount := ProjX to (ProjX + ColWidth) do
  116.                     Begin If ProjY < Range[BarCount] Then Begin
  117.              InterPollColor(ProjY, Range[BarCount], BarCount, MapColor);
  118.  Range[BarCount] := ProjY; End;End;End;End;End;End;End;
  119.  
  120. Function Voxelize : Real;
  121.  
  122. Var Time : Longint Absolute $0000:$046c; StartTime, EndTime, Frame : Longint;
  123.   XPos, YPos, Dir : Integer; Quit : Boolean;
  124.  
  125. Begin
  126.   InitGraph; InitPalette;Quit:=False;XPos:=0;YPos:=0;Dir:=0;StartTime:=Time;
  127.   Frame := 0;
  128.   Repeat
  129.     Dir := Dir And 511; Frame := Frame + 1;
  130.     ClearScreen(VScreen^); DisplayLandscape(XPos Shr 8, YPos Shr 8, Dir);
  131.     CopyScreen(VScreen^, Screen^);
  132.     If KeyPressed Then Begin
  133.         Case ReadKey of #0 : Case ReadKey of
  134.              #75 : Dir := Dir - 10; #77 : Dir := Dir + 10;   { Right Key }
  135.              #72 : Begin XPos:=(XPos+Sine[Dir] Shl 2);
  136.                    YPos := (YPos + CoSine[Dir] Shl 2); End;
  137.              #80 : Begin XPos := (XPos - Sine[Dir] Shl 2);
  138.                      YPos := (YPos - CoSine[Dir] Shl 2); End;
  139.            End; #27 : Quit := True; End; End;
  140.   Until Quit; EndTime := Time; CloseGraph; Dispose(Map);
  141.   Voxelize :=  (Frame*18.2)/(EndTime-StartTime); End;
  142.  
  143. Begin
  144.   MakeSinus; CreateMap; Writeln(Voxelize:5:2, ' Frames per second');
  145. End.
  146.  
  147.  
  148.  
  149.  
  150. This one is a little longer (ok, alot), but it looks cool!
  151.  
  152.      Alex
  153.  
  154. ... I haven't lost my mind; it's backed up on tape somewhere!
  155. ___ Blue Wave/QWK v2.12
  156.  
  157. --- WILDMAIL!/WC v4.11 
  158.  * Origin: Cormac mac Airt BBS - Cincinnati, OH (513) 731-4493  (1:108/180.0)
  159. SEEN-BY: 108/50 155 180 220 325 396/1 3615/50 51
  160. PATH: 108/180 220 3615/50
  161.