{  (c) 1984 by Neil J. Rubenking   }
program Amazing;
type
  ColumnType = 1..80;
  regpack = record
              ax,bx,cx,dx,bp,di,si,ds,es,flags: integer;
            end;
var
  StopNow          : boolean;
  StCol, EndCol    : ColumnType;
  StRow, EndRow    : 1..24;
  BlankChance      : 1..120;
  Ex               : array[1..42] of char;
  ThisRow, LastRow : array[1..80] of char;
  N, M, ScreenSeg  : integer;
  attribute        : byte;
  OneUp, OneLeft, OneDown, OneRight,
    TwoUp, TwoLeft, TwoDown, TwoRight,
    NoUp, NoLeft, NoDown, NoRight : set of char;
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
function Escape: boolean;
var
  C, D : char;
begin
  D := chr(0);
  if keypressed then read(Kbd,C);
  if keypressed then read(Kbd,D);
  if (C = chr(27)) and (D = chr(0)) then Escape := true
    else Escape := false;
end;
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
function FindColor:byte;
  var
    ranfor, ranbak : byte;
  begin
    ranfor := random(16);
    repeat
      ranbak := random(8)
    until ranbak <> ranfor;
    FindColor := (ranbak shl 4) or ranfor;
  end;
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
function ReadScreen(col,row:byte):char;
var
  LocationCode : integer;
  begin
    LocationCode := (col-1)*2 + (row-1)*160;
    ReadScreen   := chr(Mem[ScreenSeg:LocationCode]);
  end;
{============================================================================}
procedure WriteScrn(col, row: byte; thisChar:char);
var
  LocationCode : integer;
begin
  LocationCode := (col-1)*2 + (row-1)*160;
  Mem[ScreenSeg:locationCode] := ord(ThisChar);
  Mem[ScreenSeg:LocationCode+1] := attribute;
end;
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
procedure initialize;
  begin
  StCol       := 0;
  EndCol      := 0;
  StRow       := 0;
  EndRow      := 0;
  BlankChance := 0;
   IF (Mem[0000:1040] AND 48) <> 48 THEN ScreenSeg := $B800
   ELSE ScreenSeg := $B000;
  attribute := 15;
  randomize;
  repeat
    GotoXY(5,5);
    Write('Starting column (1-79):');
    GotoXY(7,6);
    Write('Ending column (1-79):');
    GotoXY(29,5); Read(StCol);
    GotoXY(29,6); Read(EndCol);
    until (StCol>0) and (EndCol>StCol) and (EndCol<80);
  WriteLn;
  repeat
    GotoXY(8,8);
    Write('Starting row (1-24):');
    GotoXY(10,9);
    Write('Ending row (1-24):');
    GotoXY(29,8); Read(StRow);
    GotoXY(29,9); Read(EndRow);
    until (StRow>0) and (EndRow>StRow) and (EndRow<25);
  WriteLn;
  repeat
    WriteLn('Enter # of blanks in character list.  (1-120)');
    read(BlankChance);
    until (BlankChance>0) and (BlankChance<121);
  ClrScr;
  for N := 1 to 40 do Ex[N] := chr(178 + N);
  for N := 1 to BlankChance do Ex[40 + N] := ' ';
  OneUp    := [Ex[ 1],Ex[ 2],Ex[ 3],Ex[12],Ex[14],Ex[15],Ex[17],Ex[19],
              Ex[20],Ex[29],Ex[34],Ex[38],Ex[39]];
  OneLeft  := [Ex[ 2],Ex[ 4],Ex[ 5],Ex[11],Ex[13],Ex[15],Ex[16],Ex[18],
              Ex[19],Ex[30],Ex[32],Ex[37],Ex[39]];
  OneDown  := [Ex[ 1],Ex[ 2],Ex[ 3],Ex[ 6],Ex[13],Ex[16],Ex[17],Ex[19],
              Ex[20],Ex[31],Ex[35],Ex[38],Ex[40]];
  OneRight := [Ex[14],Ex[15],Ex[16],Ex[17],Ex[18],Ex[19],Ex[21],Ex[30],
              Ex[32],Ex[33],Ex[36],Ex[37],Ex[40]];
  TwoUp    := [Ex[ 4],Ex[ 7],Ex[ 8],Ex[10],Ex[11],Ex[21],Ex[22],Ex[24],
              Ex[26],Ex[28],Ex[30],Ex[33],Ex[37]];
  TwoLeft  := [Ex[ 3],Ex[ 6],Ex[ 7],Ex[ 9],Ex[10],Ex[12],Ex[24],Ex[25],
              Ex[27],Ex[28],Ex[29],Ex[31],Ex[38]];
  TwoDown  := [Ex[ 4],Ex[ 5],Ex[ 7],Ex[ 8],Ex[ 9],Ex[21],Ex[23],Ex[25],
              Ex[26],Ex[28],Ex[32],Ex[36],Ex[37]];
  TwoRight := [Ex[20],Ex[22],Ex[23],Ex[24],Ex[25],Ex[26],Ex[27],Ex[28],
              Ex[29],Ex[31],Ex[34],Ex[35],Ex[38]];
  NoUp     := [Ex[ 5],Ex[ 6],Ex[ 9],Ex[13],Ex[16],Ex[18],Ex[23],Ex[25],
              Ex[27],Ex[31],Ex[32],Ex[35],Ex[36],Ex[40],Ex[41]];
  NoLeft   := [Ex[ 1],Ex[ 8],Ex[14],Ex[17],Ex[20],Ex[21],Ex[22],Ex[23],
              Ex[26],Ex[33],Ex[34],Ex[35],Ex[36],Ex[40],Ex[41]];
  NoDown   := [Ex[10],Ex[11],Ex[12],Ex[14],Ex[15],Ex[18],Ex[22],Ex[24],
              Ex[27],Ex[29],Ex[30],Ex[33],Ex[34],Ex[39],Ex[41]];
  NoRight  := [Ex[ 1],Ex[ 2],Ex[ 3],Ex[ 4],Ex[ 5],Ex[ 6],Ex[ 7],Ex[ 8],
              Ex[ 9],Ex[10],Ex[11],Ex[12],Ex[13],Ex[39],Ex[41]];
  for N := StCol to EndCol do LastRow[N] := ' ';
  end;  {procedure initialize}
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
   function ValidNeighbour(Nabe:char; P:ColumnType):char;
   var
     XX : char;
     YY : 1..80;
     begin
     if Nabe in OneRight then
       begin
       if LastRow[P] in OneDown then
         begin
         repeat
           XX := Ex[random(40)+1]
         until (XX in OneUp) and (XX in OneLeft)
         end;
       if LastRow[P] in TwoDown then
         begin
         repeat
         XX := Ex[random(40)+1]
         until (XX in TwoUp) and (XX in OneLeft)
         end;
       if LastRow[P] in NoDown then
         begin
         repeat
         XX := Ex[random(40)+1]
         until (XX in NoUp) and (XX in OneLeft)
         end;
       end;    {if Nabe in OneRight}
     if Nabe in TwoRight then
       begin
       if LastRow[P] in OneDown then
         begin
         repeat
         XX := Ex[random(40)+1]
         until (XX in OneUp) and (XX in TwoLeft)
         end;
       if LastRow[P] in TwoDown then
         begin
         repeat
         XX := Ex[random(40)+1]
         until (XX in TwoUp) and (XX in TwoLeft)
         end;
       if LastRow[P] in NoDown then
         begin
         repeat
         XX := Ex[random(40)+1]
         until (XX in NoUp) and (XX in TwoLeft)
         end;
       end;  {if Nabe in TwoRight}
     if Nabe in NoRight then
       begin
       if LastRow[P] in OneDown then
         begin
         repeat
         XX := Ex[random(40)+1]
         until (XX in OneUp) and (XX in NoLeft)
         end;
       if LastRow[P] in TwoDown then
         begin
         repeat
         XX := Ex[random(40)+1]
         until (XX in TwoUp) and (XX in NoLeft)
         end;
       if LastRow[P] in NoDown then
         begin
         repeat
         YY := random(40+BlankChance)+1;
         if YY <= 41 then
           XX := Ex[YY]
           else XX := ' ';
         until (XX in NoUp) and (XX in NoLeft)
         end;
       end;   {if Nabe in NoRight}
       ValidNeighbour := XX;
     end;  {function ValidNeighbour}
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
procedure MostRows;
var
  ThisChar : char;
  {--------------------------------------------}
  procedure LastOne;
    begin
      repeat
      ThisRow[EndCol] := ValidNeighbour(ThisRow[EndCol-1],EndCol)
      until ThisRow[EndCol] in NoRight;
    end;
  {--------------------------------------------}
  begin  {main procedure MostRows}
    if ScreenSeg = $B800 then
      if random(10) mod 10 = 0 then
        attribute := findcolor;
    ThisRow[StCol] := ValidNeighbour(Ex[41],StCol);
    writeScrn(StCol,M,ThisRow[StCol]);
    for N := StCol+1 to EndCol-1 do
      begin
      ThisRow[N] := ValidNeighbour(ThisRow[N-1],N);
      WriteScrn(N,M,ThisRow[N]);
      end;
    LastOne;
    WriteScrn(EndCol,M,ThisRow[EndCol]);
    LastRow := ThisRow;
  end;
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
procedure FinalRow;
var
  counter : byte;
  begin
    repeat
      ThisRow[StCol] := ValidNeighbour(Ex[41],StCol)
      until ThisRow[StCol] in NoDown;
    writeScrn(StCol,EndRow,ThisRow[StCol]);
    for N := StCol+1 to EndCol-1 do
      begin
      repeat
        ThisRow[N] := ValidNeighbour(ThisRow[N-1],N)
        until ThisRow[N] in NoDown;
      WriteScrn(N,EndRow,ThisRow[N]);
      end;
    counter := 0;
    repeat
      ThisRow[EndCol] := ValidNeighbour(ThisRow[EndCol-1],EndCol);
      counter := counter + 1;
      until ((ThisRow[EndCol] in NoDown) and (ThisRow[EndCol] in NoRight))
          or (counter = 100);
    if counter = 100 then ThisRow[EndCol] := Ex[41];
    WriteScrn(EndCol,EndRow,ThisRow[EndCol]);
end;
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
procedure ScrollUp(fun:byte);
var
  recpack:          regpack;
  ah,al,bh,bl,ch,cl,dh,dl:   byte;

begin
  ah := 6;
  al := fun;
  bh := 15;  {attribute}
  ch := StRow-1;
  cl := StCol-1;
  dh := EndRow;
  dl := EndCol+1;
  with recpack do
  begin
    ax := ah shl 8 + al;
    bx := bh shl 8 + bl;
    cx := ch shl 8 + cl;
    dx := dh shl 8 + dl;
  end;
  intr($10,recpack);                     {call interrupt}
end;
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
procedure MovingMaze;
begin
  M := EndRow;
  for N := StCol to EndCol do ThisRow[N] := ' ';
  ScrollUp(0);
  repeat
    MostRows;
    ScrollUp(1);
  until Escape;
end;
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
Begin
  initialize;
  for M := StRow to (EndRow-1) do MostRows;
  FinalRow;
  GotoXY(1,1);
  Write('Press Escape ');
  repeat until Escape;
  read(Kbd);
  MovingMaze;
  ClrScr;
end.