program HexTunnel;

uses
   crt;

const
   Speed = 25;
   RndS = 22;
   VGA = $A000;
   d = 200;
   r = 100;
   MaxZ = 2000;
   HexNum = 10;
   Alpha = 2 * Pi / HexNum;

type
   IntPoint  = record
      x, y : Integer;
   end;
   RealPoint = record
      x, y : Real;
   end;
   VirtScr = array [1..64000] of byte;
   VirtPtr = ^VirtScr;

var
   VirtS1, VirtS2 : VirtPtr;
   VS1, VS2 : word;
   Hex, Hex1 : array [1..6] of RealPoint;
   H : array [1..6] of IntPoint;
   HexShow : array [0..255] of Boolean;
   SinA, CosA ,SinAh ,CosAh : Real;

procedure SetCol (Col, R, G, B : Byte); assembler;
asm
   mov   dx, 3c8h
   mov   al, [col]
   out   dx, al
   inc   dx
   mov   al, [r]
   out   dx, al
   mov   al, [g]
   out   dx, al
   mov   al, [b]
   out   dx, al
end;

procedure Cls (Col : Byte; Where : Word);
begin
   asm
      push  es
      mov   cx, 32000;
      mov   es, [where]
      xor   di, di
      mov   al, [col]
      mov   ah, al
      rep   stosw
      pop   es
   end;
end;

procedure PutPixel (x, y : Integer; Col : Byte; Where : Word); assembler;
asm
   mov   ax, [Where]
   mov   es, ax
   mov   bx, [x]
   mov   dx, [y]
   mov   di, bx
   mov   bx, dx
   shl   dx, 8
   shl   bx, 6
   add   dx, bx
   add   di, dx
   mov   al, [Col]
   stosb
end;

procedure PutPixel1 (x, y  : Integer; Col : Byte; Where : Word);
begin
   if (x >= 0) and (x < 320) and (y >= 0) and (y < 200) then
      PutPixel (x, y, col, Where);
end;

procedure Line(a, b, c, d : Integer; Col : Integer; Where : Word);
   function Sign(a : Real) : Integer;
   begin
      if a > 0 then Sign := +1
      else if a < 0 then Sign := -1
      else Sign := 0;
   end;
var
   Count, i, s, dx1, dy1, dx2, dy2, u, v, m, n : integer;
begin
   Count := 50;
   u := c - a;
   v := d - b;
   dx1 := Sign (u);
   dy1 := Sign (v);
   dx2 := Sign (u);
   dy2 := 0;
   m := Abs (u);
   n := Abs (v);
   if m <= n then
   begin
      dx2 := 0 ;
      dy2 := Sign (v);
      m := Abs (v);
      n := Abs (u);
   end;
   s := m shr 1;
   for i := 0 to m do
   begin
      PutPixel1 (a, b, Col, Where);
      Inc (Count);
      if Count = 101 then Count := 50;
      s := s + n;
      if m <= s then
      begin
         s := s - m;
         a := a + dx1;
         b := b + dy1;
      end
      else
      begin
         a := a + dx2;
         b := b + dy2;
      end;
   end;
end;

procedure Flip (Source, Dest : Word); assembler;
asm
   push  ds
   mov   ax, [Dest]
   mov   es, ax
   mov   ax, [Source]
   mov   ds, ax
   xor   si, si
   xor   di, di
   mov   cx, 32000
   rep   movsw
   pop   ds
end;

procedure TFlip (Source, Dest : Word); assembler;
asm
   push  ds
   mov   ax, [Dest]
   mov   es, ax
   mov   ax, [Source]
   mov   ds, ax
   xor   si, si
   xor   di, di
   mov   cx, 64000
  @1:
   lodsb
   cmp   al, es:[di]
   ja    @2
   mov   al, es:[di]
  @2:
   stosb
   loop @1
   pop   ds
end;

procedure TrueBlur (Source, Dest : Word);
var
   t, x, y : Integer;
begin
   for x := 1 to 318 do
      for y := 1 to 198 do
      begin
         t := y shl 8 + y shl 6;
         PutPixel (x, y, (Mem[Source:x + t + 1] + Mem[Source:x + t - 1] +
          Mem[Source:x + t + 320] + Mem[Source:x + t - 320] +
           Mem[Source:x + t + 321] + Mem[Source:x + t - 321] +
            Mem[Source:x + t + 319] + Mem[Source:x + t - 319]) div 8, Dest);
      end;
end;

procedure Init;
var
   Color1, Color2 : Byte;
   i, j, x, y : Integer;
   DirFlag : Boolean;
begin
   asm
      mov   ax, 0013h
      int   10h
   end;
   RandSeed := RndS;
   GetMem (VirtS1, 64000);
   VS1 := Seg (VirtS1^);
   GetMem (VirtS2, 64000);
   VS2 := Seg (VirtS2^);
   Cls (0, VS1);
   Cls (0, VS2);
   for i := 0 to 31 do
   begin
      SetCol (i, 0, 0, i * 2);
   end;
   for i := 0 to 31 do
   begin
      SetCol (32 + i, i * 2, i * 2, 63);
   end;
   for i := 0 to 31 do
   begin
      SetCol (64 + i, 63, 63, 63);
   end;
   for i := 64 to 160 do
      for j := 0 to 10 do
      begin
         Color1 := Round (-i / 160 * 31 + (10 - j) / 10 * 63);
         if Color1 > 63 then Color1 := 0;
         PutPixel (160 + i, 100 - j, Color1, VS2);
         PutPixel (160 + i, 100 + j, Color1, VS2);
         PutPixel (160 - i, 100 - j, Color1, VS2);
         PutPixel (160 - i, 100 + j, Color1, VS2);
      end;
   for i := 0 to 64 do
      for j := 0 to 64 do
      begin
         if j <= 10 then
           Color1 := Round (-i / 160 * 31 + (10 - j) / 10 * 63)
         else
           Color1 := 0;
         Color2 := (64 - Round (sqrt (sqr (i) + sqr (j))));
         if Color1 > 63 then Color1 := 0;
         if Color2 > 63 then Color2 := 0;
         if Color2 < Color1 then Color2 := Color1;
         PutPixel (160 + i, 100 - j, Color2, VS2);
         PutPixel (160 + i, 100 + j, Color2, VS2);
         PutPixel (160 - i, 100 - j, Color2, VS2);
         PutPixel (160 - i, 100 + j, Color2, VS2);
      end;
   for j := 1 to 5 do
   begin
      case Random (4) of
         0: begin   x :=   0;   y := Random (200);   DirFlag :=  true;   end;
         1: begin   x := 319;   y := Random (200);   DirFlag :=  true;   end;
         2: begin   x := Random (320);   y :=   0;   DirFlag := false;   end;
         3: begin   x := Random (320);   y := 199;   DirFlag := false;   end;
      end;
      for i := 15 downto 0 do
      begin
         if DirFlag then
         begin
            Line (160, 100, x, y + i, (63 - i * 4), VS1);
            Line (160, 100, x, y - i, (63 - i * 4), VS1);
         end
         else
         begin
            Line (160, 100, x + i, y, (63 - i * 4), VS1);
            Line (160, 100, x - i, y, (63 - i * 4), VS1);
         end;
      end;
      TFlip (VS1, VS2);
   end;
   TrueBlur (VS2, VS1);
   TrueBlur (VS1, VS2);
   for i := 0 to 255 do
      if Random (4) = 0 then HexShow[i] := true else HexShow[i] := false;
   Hex[1].x :=   0.00;   Hex[1].y :=  30.00;
   Hex[2].x :=  25.98;   Hex[2].y :=  15.00;
   Hex[3].x :=  25.98;   Hex[3].y := -15.00;
   Hex[4].x :=   0.00;   Hex[4].y := -30.00;
   Hex[5].x := -25.98;   Hex[5].y := -15.00;
   Hex[6].x := -25.98;   Hex[6].y :=  15.00;
   SinA  := Sin (Alpha);
   CosA  := Cos (Alpha);
   SinAh := Sin (Alpha / 2);
   CosAh := Cos (Alpha / 2);
end;

procedure Finish;
begin
   asm
      mov ax, 0003h
      int 10h
   end;
   FreeMem (VirtS1, 64000);
   FreeMem (VirtS2, 64000);
end;

var
   i, j, z, z1 : Integer;
   Temp, x1, y1 : Real;
   Flag : Boolean;
   HexIndex, HexIndex1, HexColor : Byte;
begin
   Init;
   z := 155;
   HexIndex := 0;
   repeat
      Flip (VS2, VS1);
      Inc (z, Speed);
      if z < 35 then
      begin
         z := 155;
         Inc (HexIndex, HexNum * 2);
      end;
      if z > 155 then
      begin
         z := 35;
         Dec (HexIndex, HexNum * 2);
      end;
      z1 := z;
      HexIndex1 := HexIndex;
      Flag := false;
      HexColor := 95;
      repeat
         Flag := not Flag;
         for i := 1 to 6 do
         begin
            Temp := d / (z1 + Hex[i].y);
            Hex1[i].x := Temp * Hex[i].x;
            Hex1[i].y := Temp * r;
         end;
         if Flag then
            for i := 1 to 6 do
            begin
               x1 := Hex1[i].x;
               y1 := Hex1[i].y;
               Hex1[i].x := x1 * CosAh - y1 * SinAh;
               Hex1[i].y := x1 * SinAh + y1 * CosAh;
            end;
         for j := 1 to HexNum do
         begin
            for i := 1 to 6 do
            begin
               x1 := Hex1[i].x;
               y1 := Hex1[i].y;
               Hex1[i].x := x1 * CosA - y1 * SinA;
               Hex1[i].y := x1 * SinA + y1 * CosA;
               H[i].x := Round (Hex1[i].x) + 160;
               H[i].y := Round (Hex1[i].y) + 100;
            end;
            Inc (HexIndex1);
            if HexShow[HexIndex1] then
            begin
               Line (H[1].x, H[1].y, H[2].x, H[2].y, HexColor, VS1);
               Line (H[2].x, H[2].y, H[3].x, H[3].y, HexColor, VS1);
               Line (H[3].x, H[3].y, H[4].x, H[4].y, HexColor, VS1);
               Line (H[4].x, H[4].y, H[5].x, H[5].y, HexColor, VS1);
               Line (H[5].x, H[5].y, H[6].x, H[6].y, HexColor, VS1);
               Line (H[6].x, H[6].y, H[1].x, H[1].y, HexColor, VS1);
            end;
         end;
         Inc (z1, 60);
         if HexColor > 95 then Dec (HexColor);
      until z1 > MaxZ;
      TrueBlur (VS1, VGA);
   until KeyPressed;
   Finish;
end.