[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]