unit LabGen;

interface

uses
  windows, messages, sysutils, loadz, aData;

procedure GenerateLab;

implementation

uses
  MyCRT;

const
  XSize = RESOLUTION_X + 1;
  YSize = RESOLUTION_Y + 1;

type
  PRoom = ^Room;
  Room = record
    x1, x2, y1, y2: integer;
    room1, room2: PRoom;
  end;
  TRoom = record
    x, y, width, height: integer;
  end;

var
  root: PRoom;
  arr: array[1..RESOLUTION_X, 1..RESOLUTION_Y] of byte;
  roomsWith, roomsWithout: array of TRoom;

procedure DrawLab;
var
  i, j: integer;
begin
  for j := 1 to RESOLUTION_Y do
    for i := 1 to RESOLUTION_X do
      osvkletka(i, j);
end;

procedure CopyCoords(dest, src: PRoom);
begin
  dest^.x1 := src^.x1;
  dest^.x2 := src^.x2;
  dest^.y1 := src^.y1;
  dest^.y2 := src^.y2;
end;

procedure PrintRoom(room1: PRoom);
var
  x, y: integer;
begin
  for x := room1^.x1 to room1^.x2 do
  begin
    SetElement(x, room1^.y1, 'Wall');
    SetElement(x, room1^.y2, 'Wall');
  end;
  for y := room1^.y1 to room1^.y2 do
  begin
    SetElement(room1^.x1, y, 'Wall');
    SetElement(room1^.x2, y, 'Wall');
  end;
end;

procedure PrintRoomRec(room1: PRoom);
begin
  if not Assigned(room1) then
    exit;
  PrintRoom(room1);
  PrintRoomRec(room1^.room1);
  PrintRoomRec(room1^.room2);
end;

procedure ProcessRoom(room: PRoom; Size: integer);
var
  SizeX, SizeY: integer;
  pos: integer;
begin
  SizeX := room^.x2 - room^.x1;
  SizeY := room^.y2 - room^.y1;
  room^.room1 := nil;
  room^.room2 := nil;
  if (SizeX < Size) or (SizeY < Size) then
    exit;
  New(room^.room1);
  New(room^.room2);
  room^.room1^.room1 := nil;
  room^.room1^.room2 := nil;
  room^.room2^.room1 := nil;
  room^.room2^.room2 := nil;
  CopyCoords(room^.room1, room);
  CopyCoords(room^.room2, room);
  if (SizeX > SizeY) then
  begin
    pos := room^.x1 + Random(SizeX div 3) + (SizeX div 3);
    room^.room1^.x2 := pos;
    room^.room2^.x1 := pos;
  end
  else
  begin
    pos := room^.y1 + Random(SizeY div 3) + (SizeY div 3);
    room^.room1^.y2 := pos;
    room^.room2^.y1 := pos;
  end;
  ProcessRoom(room^.room1, Size);
  ProcessRoom(Room^.room2, Size);
end;

procedure Map(Size: integer);
begin
  New(root);
  root^.x1 := 1;
  root^.x2 := XSize - 1;
  root^.y1 := 1;
  root^.y2 := YSize - 1;
  root^.room1 := nil;
  root^.room2 := nil;
  ProcessRoom(root, Size);
  PrintRoomRec(root);
end;

procedure initarr;
var
  x, y: integer;
begin
  for y := 1 to RESOLUTION_Y do
    for x := 1 to RESOLUTION_X do
    begin
      cur_lev.map[x, y] := EmptyKletka;
      SetElement(x, y, 'Floor');
      arr[x, y] := 0;
    end;
end;

function GetWidth(x, y: integer): integer;
var
  i: integer;
begin
  i := x;
  Result := 0;
  while (not IsType(i, y, 'Wall')) do
  begin
    inc(Result);
    inc(i);
  end;
end;

function GetHeight(x, y: integer): integer;
var
  i: integer;
begin
  i := y;
  Result := 0;
  while (not IsType(x, i, 'Wall')) do
  begin
    inc(Result);
    inc(i);
  end;
end;

procedure SetRect(x, y, width, height: integer);
var
  i, j: integer;
begin
  for j := 1 to height do
    for i := 1 to width do
      arr[x + i - 1, y + j - 1] := 1;
end;

procedure FindRooms;
var
  i, j: integer;
  len: integer;
begin
  SetLength(roomsWith, 0);
  SetLength(roomsWithout, 0);
  for j := 2 to RESOLUTION_Y - 1 do
    for i := 2 to RESOLUTION_X - 1 do
      if (IsType(i, j, 'Floor')) and (arr[i, j] = 0) then
      begin
        SetLength(roomsWithout, Length(roomsWithout) + 1);
        len := Length(roomsWithout) - 1;
        with roomsWithout[len] do
        begin
          x := i;
          y := j;
          width := GetWidth(x, y);
          height := GetHeight(x, y);
          SetRect(x, y, width, height);
        end;
      end;
end;

procedure DrawArr;
var
  i, j: integer;
begin
  for j := 1 to RESOLUTION_Y do
    for i := 1 to RESOLUTION_X do
      PutSymbol(i, j, white, inttostr(arr[i, j])[1]);
  readkey;
end;

procedure DrawRooms;
var
  i: integer;
begin
  GotoXY(1, 1);
  for i := 0 to Length(roomsWithout) - 1 do
    writeln(roomsWithout[i].x, ' ', roomsWithout[i].y, ' ', roomsWithout[i].width, ' ', roomsWithout[i].height);
  readkey;
end;

procedure MakeExit;
var
  i: integer;
  x, y: integer;
begin
  inc(data.PrisonLevel);
  if (data.PrisonLevel >= data.MaxLevel) then
    exit;
  repeat
    i := Random(Length(roomsWithout));
    x := Random(roomsWithout[i].width - 1) + roomsWithout[i].x;
    y := Random(roomsWithout[i].height - 1) + roomsWithout[i].y;
  until (IsFloor(x, y));
  SetElement(x, y, 'PrisonDown');
end;

procedure FillRoom(room: TRoom);
var
  i, j: integer;
begin
  for j := 1 to room.height do
    for i := 1 to room.width do
      arr[room.x + i - 1, room.y + j - 1] := 2;
end;

procedure MakeEntrace;
var
  i: integer;
  x, y: integer;
begin
  repeat
    i := Random(Length(roomsWithout));
    x := Random(roomsWithout[i].width - 1) + roomsWithout[i].x;
    y := Random(roomsWithout[i].height - 1) + roomsWithout[i].y;
  until (IsFloor(x, y));
  SetLength(roomsWith, 1);
  roomsWith[0] := roomsWithout[i];
  FillRoom(roomsWith[0]);
  for i := i to Length(roomsWithout) - 2 do
    roomsWithout[i] := roomsWithout[i + 1];
  SetLength(roomsWithout, Length(roomsWithout) - 1);
  SetElement(x, y, 'PrisonUp');
  cur_lev.map[x, y].levAttrz := data.posx * 256 + data.posy;
  data.posx := x;
  data.posy := y;
  if data.PrisonLevel = 1 then
    data.LastLocation := data.location;
  data.location := 'prison' + Inttostr(data.PrisonLevel);
end;

function IsPodhForDoor(x, y: integer; dx, dy: shortint): boolean;
begin
  IsPodhForDoor := false;
  if (arr[x + dx, y + dy] = 2) then
    exit;
  IsPodhForDoor := true;
  if (IsType(x - 1, y, 'Floor')) and (IsType(x + 1, y, 'Floor')) then
    exit;
  if (IsType(x, y - 1, 'Wall')) and (IsType(x, y + 1, 'Wall')) then
    exit;
  IsPodhForDoor := false;
end;

procedure SelectWall(room: TRoom; var x, y: integer; var dx, dy: shortint);
var
  arr: array of byte;
  i: integer;
begin
  SetLength(arr, 0);
  if (room.x > 2) then
  begin
    SetLength(arr, Length(arr) + 1);
    arr[Length(arr) - 1] := 1;
  end;
  if (room.y > 2) then
  begin
    SetLength(arr, Length(arr) + 1);
    arr[Length(arr) - 1] := 2;
  end;
  if (room.x + room.width) < RESOLUTION_X then
  begin
    SetLength(arr, Length(arr) + 1);
    arr[Length(arr) - 1] := 3;
  end;
  if (room.y + room.height) < RESOLUTION_Y then
  begin
    SetLength(arr, Length(arr) + 1);
    arr[Length(arr) - 1] := 4;
  end;
  repeat
    i := Random(Length(arr));
    case arr[i] of
      1:
      begin
        x := room.x - 1;
        y := room.y + Random(room.height - 1) + 1;
        dx := -1;
        dy := 0;
      end;
      2:
      begin
        x := room.x + Random(room.width - 1) + 1;
        y := room.y - 1;
        dx := 0;
        dy := -1;
      end;
      3:
      begin
        x := room.x + room.width;
        y := room.y + Random(room.height - 1) + 1;
        dx := 1;
        dy := 0;
      end;
      4:
      begin
        x := room.x + Random(room.width - 1) + 1;
        y := room.y + room.height;
        dx := 0;
        dy := 1;
      end;
    end;
  until (IsPodhForDoor(x, y, dx, dy));
end;

procedure SetRoom(x, y: integer);
var
  i, j: integer;
begin
  for i := 1 to Length(roomsWithout) do
  begin
    if (x in [roomsWithout[i].x..roomsWithout[i].x + roomsWithout[i].width]) and
      (y in [roomsWithout[i].y..roomsWithout[i].y + roomsWithout[i].height]) then
    begin
      SetLength(roomsWith, Length(RoomsWith) + 1);
      roomsWith[Length(roomsWith) - 1] := roomsWithout[i];
      FillRoom(roomsWith[Length(roomsWith) - 1]);
      for j := i to Length(roomsWithout) - 2 do
        roomsWithout[j] := roomsWithout[j + 1];
      SetLength(roomsWithout, Length(roomsWithout) - 1);
      exit;
    end;
  end;
end;

procedure MakeRound(room: TRoom);
var
  i, j: integer;
  room1: TRoom;
begin
  if (room.x > 2) then
  begin
    for i := 1 to room.width do
      if arr[i + room.x - 1, room.y - 2] <> 2 then
      begin
        room1 := FindRoom(i + room.x - 1, room.y - 2);
      end;
  end;
end;

procedure GenerateLab;
var
  x, y: integer;
  dx, dy: shortint;
  i: integer;
begin
  initarr;
  Map(Random(5) + 9);
  FindRooms;
  MakeExit;
  MakeEntrace;
  MakeRound(roomsWith[0]);
  DrawLab;
  readkey;
end;

end.
