Unit Voxel;
Interface
Uses
  CRT,DOS,GRAPHVGA,Libuses;
const
  Mult = 512;
  Divs = Mult;
  Sword= 9;
  Modul = 5;
  Ang  : Word = 0;
  Dist = 1;
  AddX = 1000;
  Multip = 2;
  MX : Integer = 200;  { -400 }
  MY : Integer = 1;
  MZ : Integer = 1;

{  Mx   = Mult*100;
  MY   = Mult;   {  5 }
{ Mz   = Mult;   { 8 }
{    Mx   = 20;
  MY   = 70;    5
  Mz   = 20;    8 }
{
  YLen : Array[-60..-20] Of Byte =
        ( 4, 4, 4, 4, 4, 4, 4, 4, 4 ,4, 4, 4, 4, 4,
          6, 6, 6, 6, 6, 6, 6, 6, 6 ,6, 6, 6, 6,
          8, 8, 8, 8, 8, 8, 8, 8, 8 ,8, 8, 8, 8, 8);
}
  LX   : Array[-60..-20] of Byte =
        ( 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
          1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
          2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
          3, 3, 3, 3, 3);
{
  Db   : Array[-60..-19,0..15] of byte = (
(  0,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15),
(  0,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15),
(  0,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15),
(  0,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15),
(  0,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15),
(  0,  0,  1,  1,  2,  2,  3,  3,  4,  4,  5,  5,  6,  6,  7,  7),
(  0,  0,  1,  1,  2,  2,  3,  3,  4,  4,  5,  5,  6,  6,  7,  7),
(  0,  0,  1,  1,  2,  2,  3,  3,  4,  4,  5,  5,  6,  6,  7,  7),
(  0,  0,  1,  1,  2,  2,  3,  3,  4,  4,  5,  5,  6,  6,  7,  7),
(  0,  0,  0,  1,  1,  1,  2,  2,  2,  3,  3,  3,  4,  4,  4,  5),
(  0,  0,  0,  1,  1,  1,  2,  2,  2,  3,  3,  3,  4,  4,  4,  5),
(  0,  0,  0,  1,  1,  1,  2,  2,  2,  3,  3,  3,  4,  4,  4,  5),
(  0,  0,  0,  1,  1,  1,  2,  2,  2,  3,  3,  3,  4,  4,  4,  5),
(  0,  0,  0,  0,  1,  1,  1,  1,  2,  2,  2,  2,  3,  3,  3,  3),
(  0,  0,  0,  0,  1,  1,  1,  1,  2,  2,  2,  2,  3,  3,  3,  3),
(  0,  0,  0,  0,  1,  1,  1,  1,  2,  2,  2,  2,  3,  3,  3,  3),
(  0,  0,  0,  0,  1,  1,  1,  1,  2,  2,  2,  2,  3,  3,  3,  3),
(  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  2,  2,  2,  2,  2,  3),
(  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  2,  2,  2,  2,  2,  3),
(  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  2,  2,  2,  2,  2,  3),
(  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  2,  2,  2,  2,  2,  3),
(  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  2,  2,  2,  2),
(  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  2,  2,  2,  2),
(  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  2,  2,  2,  2),
(  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  2,  2,  2,  2),
(  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  1,  2,  2),
(  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  1,  2,  2),
(  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  1,  2,  2),
(  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  1,  2,  2),
(  0,  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  1,  1),
(  0,  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  1,  1),
(  0,  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  1,  1),
(  0,  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  1,  1),
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  1),
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  1),
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  1),
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1,  1),
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1),
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1),
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1),
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1,  1),
(  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  1,  1,  1,  1,  1));
}
  Procedure InitVoxel;
  Procedure FolowPath;
  Procedure CloseVoxel;

Implementation
Var
  P    : ImageInfo;
  H    : ImageInfo;
  Sinus,
  Cosin : Array[ 0..359] of Integer;
 { Delta : Array[-49..49] of Shortint;}
  OldY  : integer;
  SegP  : Word;
  segH  : WOrd;
  PX,Py : integer;
  Writ  : Byte;


Procedure InitVoxel;
Var
  I : Word;
  X,Y : Word;
Begin
  LoadImage(Voxel_High,H);
{  LoadImage(Voxel_Color,P);
  Loadrix('MapHi.sci',H); }
  LoadImage(Vox_info,P);
  Move(P.Picture^,PageW^,64000);
  PutImage(P,3);
  FreeImage(P);
  SetRGb(H.Palette);
  SegP := Seg(H.Picture^);
  SegH := segP; {Seg(H.Picture^);}
  PX := 160;
  Py := 100;
  For I:=0 to 359 do
    Begin
      Cosin[i] := Round(cos(Rad(I))*Mult);
      Sinus[i] := Round(sin(Rad(I))*Mult);
    end;
  Fillchar(Ptr($A000,0)^,32000,0);
  Fillchar(Ptr(WriteS,0)^,32000,0);
  Ang := 0;
End;

Procedure HLine(X,Y : integer; Co : Byte; L,H  : Word); Assembler;
  Asm
    Mov   AX,WriteS
    Mov   ES,AX
    mov   CX,L
    mov   AX,Y
    mov   BX,X
    dec   BX
    dec   AX
    cmp   AX,0
    jl    @@Out
    cmp   AX,199
    ja    @@Out
    cmp   BX,0
    jl    @@inv
    cmp   bx,320
    jae   @@out
    mov   DX,BX
    add   DX,CX
    cmp   dx,310
    jg    @@too
    jmp   @@ok
@@inv:
    Add  Cx,bx
    mov  Bx,0
    jmp  @@ok
@@too:
    sub  Dx,320
    Sub  CX,DX
    shr  cx,1
    dec  CX
@@ok:
    cmp  Cx,0
    jle  @@out
{    shr  CX,1}
    mov  DX,320
    Mul  DX
    Add  BX,AX
    Mov  SI,H
    shl  si,1
@@Dn:
    mov  AL,Co
    Mov  AH,AL
    Mov  DX,CX
@@Ec:
    Mov  CX,DX

    Mov  DI,BX
    Rep  StosW
    Add  BX,320
    cmp  BX,64000
    ja   @@out
    Dec  SI
    Jnz  @@ec
    Jmp  @@Out
@@out:
  end;

Procedure DrawVoxel;
Label
  Out;
var
  X,Y,Z     : Integer;
  Zcal      : Integer;
  ZLen      : Byte;
  YC        : Word;
  Nx,Ny     : Word;
  X1,Y1     : integer;
  C         : Byte;
  R         : Shortint;
  Q         : Integer;
  regX,RegY : Integer;
  Higher    : Integer;
  Hig       : Integer;
  Delta     : Array[-50..50] of Byte;
Begin
  Asm
     mov  AX,WRITES
     Mov  ES,AX
     xor  DI,DI
     Mov  DX,33*160
     Mov  AX,0303h
     Mov  BX,3
@@B: Mov  CX,DX
     Rep  STOSW
     dec  AH
     dec  AL
     dec  BL
     jnz  @@b
{     Mov  Cx,16000
     xor  AX,AX
     rep  StosW}
  End;
  RegX := Cosin[ang];
  regY := Sinus[ang];
  inc(px, -(OldY*RegY) Div Divs);
  inc(Py, (OldY*RegX) Div Divs);
{  If Py >= 200 Then PY := 0;
  if Px >= 320 Then PX := 0;
  if Py <  0   Then Py := 199;
  if Px <  0   then Px := 319;}
  YC := 0;
  NX  := PX+((-(18)*RegY) Div divs);
  NY  := PY+(((18)*RegX) Div Divs);
{  Higher := Mem[SegH:(NY*320)+NX];}
{  Asm
    Mov    DX,$3C8
    Mov    AL,0
    Out    DX,AL
    Inc    DX
    Mov    AL,60
    Out    DX,AL
    Out    DX,AL
    Out    DX,AL
  End;}
  For Z:=-60 to -20 do
    Begin
      Asm
        Mov    AX,Z
        Mov    BX,AX
        Imul   Mz
        Mov    Zcal,AX
      End;
      For X:=-49 to 48 do   {  49  48  }
        begin
          Asm
          {  ; Calcul de NX }
             Mov    CL,9
             Mov    AX,X
             IMul   RegX
             Sar    AX,CL
             Cmp    DX,0
             js     @@N1
             AND    AX,07FFFh
@@N1:        Mov    BX,AX
             Mov    AX,Yc
             Sub    AX,60
             Imul   RegY
             Sar    AX,Cl
             Cmp    DX,0
             js     @@N2
             AND    AX,07FFFh
@@N2:        Add    BX,AX
             Add    BX,PX
             Mov    NX,BX
           { ; Calcul de NY }
             Mov    AX,X
             IMul   RegY
             Sar    AX,CL
             Cmp    DX,0
             js     @@N3
             AND    AX,07FFFh
@@N3:        Mov    BX,AX
             Mov    AX,Yc
             Sub    AX,60
             Imul   RegX
             Sar    AX,Cl
             Cmp    DX,0
             js     @@N4
             AND    AX,07FFFh
@@N4:        Sub    BX,AX
             Add    BX,PY
             Mov    NY,BX
           { ; Calcul de l'offset  NY * 320 + Nx :) }
             Mov    AX,NY
             Mov    BX,320
             Mul    BX
             Add    AX,NX
             Mov    DI,AX
           { ; Prise de C et Hig }
             Mov    AX,SegP
             Mov    ES,AX
             Mov    Al,Byte Ptr ES:[DI]
             Mov    C,AL
             Mov    AX,Segh
             Mov    ES,AX
             xor    AH,AH
             Mov    Al,Byte Ptr ES:[DI]
           { ; Calcul du Y }
             Xor    AH,AH
             neg    AX
{             Sub    AX,Higher}
             Mov    CL,Multip        { 5 }
             sal    AX,Cl
             Add    AX,AddX  {-2000     -2500 }
             Mov    Y,AX

             IMul   My
             Idiv   ZCal
             add    AX,30      { 160 }
             Mov    Y1,AX

             Cmp    AX,0
             Jl     Out
             Cmp    AX,199
             Ja     Out
             Mov    BX,AX
           { ; Calcul de X1 }
             Xor    DX,DX
             Mov    AX,X
             IMul   Mx
             IDiv   Zcal
             Add    AX,160
             Mov    X1,AX

             Cmp    AX,319
             Ja     Out
           end;
{          Putpixel(160+X,120+Z,C);
{          PutPixel(X1,Y1,C-db[Z,C mod 16]);}
         Hline(X1,Y1,C,lx[z] shl 1,y shr 7);
{          Hline(X1,Y1,C,Lx[Z],C-Delta[X]);}
          Delta[X] := C*2;
OUT:
        End;
      inc(Yc);

    end;
  Asm
    Mov   BX,DS
    Mov   AX,$A000
    Mov   ES,AX
    Mov   AX,WriteS
    Mov   DS,AX
    Mov   CX,32000
    Xor   DI,DI
    Mov   SI,DI
    Rep   MovsW
    Mov   DS,BX
  End;
  for x := 0 to 1 do
    WaitVBL;
end;

Procedure FolowPath;
Var
  Count : Word;
Begin
  Ang := 90;
  OldY := 2;
  For Count := 0 to 200 do
    Begin
      DrawVoxel;
      asm
        Mov   DX,Ang
        add   DX,1
        cmp   DX,360
        jb    @@cont
        mov   DX,0
@@Cont: Mov   Ang,DX
        Cmp   Count,100
        jb    @@out
        Mov   OldY,5
@@out:
      End;
    end;
  FadeOut(0,$FF,1);
  FillChar(screen^,64000,0);
End;

Procedure CloseVoxel;
begin
  Freeimage(P);
  FreeImage(H);
end;

End.