

{$R-}

unit maze_my;

interface

uses
  loadz;

procedure generate;

const
  screenwidth   = 640;
  screenheight  = 350;
  minblockwidth = 2;
  maxx = (RESOLUTION_X div 2) - 1;
  maxy = (RESOLUTION_Y div 2) - 1;
  flistsize = 5000;

  background = black;
  gridcolor  = green;
  solvecolor = white;

  rightdir = $01;
  updir    = $02;
  leftdir  = $04;
  downdir  = $08;

  unused   = $00;
  frontier = $10;
  reserved = $20;
  tree     = $30;


type
  frec = record
          column, row : byte;
         end;
  farr = array [1..flistsize] of frec;

  cellrec = record
              point : word;
              flags : byte;
            end;
  cellarr = array [1..maxx,1..maxy] of cellrec;

var
  flist     : farr;
  cell      : ^cellarr;
  fnum,
  width,
  height,
  blockwidth,
  halfblock,
  maxrun    : word;
  runset    : byte;
  ch        : char;

implementation

uses
  MyCRT;

function adjust(var x, y : word; d : byte) : boolean;
begin
  adjust := false;
  case d of
    rightdir:
    begin
      inc (x);
      adjust:= x <= width;
    end;

    updir:
    begin
      dec (y);
      adjust:= y > 0;
    end;

    leftdir:
    begin
      dec (x);
      adjust:= x > 0;
    end;

    downdir:
    begin
      inc (y);
      adjust:= y <= height;
    end;
  end;
end;


procedure remove(x, y : word);
var
  i : word;
begin
  i := cell^[x,y].point;
  with flist[fnum] do
    cell^[column,row].point := i;
  flist[i] := flist[fnum];
  dec(fnum);
end;


procedure add(x, y : word; d : byte);
var
  i : byte;
begin
  i := cell^[x,y].flags;
  case i and $30 of
    unused :
    begin
      cell^[x,y].flags := i or frontier;
      inc(fnum);
      with flist[fnum] do
      begin
        column := x;
        row    := y;
      end;
      cell^[x,y].point := fnum;
      runset := runset or d;
    end;

    frontier : runset := runset or d;
  end;
end;


procedure addfront(x, y : word);
var
  j, k : word;
  d    : byte;
begin
  remove(x, y);
  runset := 0;
  cell^[x,y].flags := cell^[x,y].flags or tree;
  d := $01;
  while d <= $08 do
  begin
    j := x;
    k := y;
    if adjust(j, k, d) then
      add(j, k, d);
    d := d shl 1;
  end;
end;

procedure rembar(x, y : word; d : byte);
var
  d2 : byte;
begin
  cell^[x,y].flags := cell^[x,y].flags or d;
  d2 := d shl 2;
  if d2 > $08 then
    d2 := d2 shr 4;
  if adjust(x, y, d) then
    cell^[x,y].flags := cell^[x,y].flags or d2;
end;


function randomdir : byte;
begin
  randomdir := 0;
  case random(4) of
    0 : randomdir := rightdir;
    1 : randomdir := updir;
    2 : randomdir := leftdir;
    3 : randomdir := downdir;
  end;
end;


procedure connect(x, y : word);
var
  j, k  : word;
  d     : byte;
  found : boolean;
begin
  found := false;
  d := 0;
  while not found do
  begin
    j := x;
    k := y;
    d := randomdir;
    if adjust(j, k, d) then
      found := cell^[j,k].flags and $30 = tree;
  end;
  rembar(x, y, d);
end;

procedure branch(x, y : word);
var
  runnum : word;
  d      : byte;
begin
  runnum := maxrun;
  connect(x, y);   
  addfront(x, y);  
  dec(runnum);
  while (runnum > 0) and (fnum > 0) and (runset > 0) do
  begin
    repeat
      d := randomdir;
    until d and runset > 0; 
    rembar(x, y, d);        
    adjust(x, y, d);
    addfront(x, y);
    dec(runnum);
  end;
end;


procedure drawmaze;
var
  x, y: word;
begin
  fillchar(cell^, sizeof(cell^), chr(0));
  fnum   := 0;
  runset := 0;
  x := random(width) + 1;
  y := random(height) + 1;
  add(x, y, rightdir);
  addfront(x, y);
  while (fnum > 0) do
    with flist[random(fnum) + 1] do
      branch(column, row);
end;

procedure showmy;
var
  cx, cy: byte;
begin
  for cx := 1 to maxx * 2 do
  begin
    for cy := 1 to maxy * 2 do
    begin
      gotoxy(cx, cy);
      textcolor(cur_lev.map[cx, cy].color);
      write(cur_lev.map[cx, cy].lev);
    end;
  end;
end;

procedure solve(x, y, endx, endy : word);
var
  j, k : word;
  d    : byte;
begin
  d := rightdir;
  while (x <> endx) or (y <> endy) do
  begin
    if d = $01 then
      d := $08
    else
      d := d shr 1;
    while cell^[x,y].flags and d = 0 do
    begin
      d := d shl 1;
      if d > $08 then
        d := d shr 4;
    end;
    j := x;
    k := y;
    adjust(x, y, d);
    with cell^[j,k] do
    begin
      flags := ((((cell^[x,y].flags xor $80) xor flags) and $80) xor flags);
    end;
  end;
end;

procedure mansolve (x,y,endx,endy: word);
var
  j, k : word;
  d    : byte;
  ch   : char;
begin
  ch := ' ';
  while ((x <> endx) or (y <> endy)) and (ch <> 'X') and (ch <> #27) do
  begin
    ch := upcase(readkey);
    d := 0;
    case ch of
      #0:
      begin
        ch := readkey;
        case ch of
          #72 : d := updir;
          #75 : d := leftdir;
          #77 : d := rightdir;
          #80 : d := downdir;
        end;
      end;

      'I' : d := updir;
      'J' : d := leftdir;
      'K' : d := rightdir;
      'M' : d := downdir;
    end;

    if d > 0 then
    begin
      j := x;
      k := y;
      if (cell^[x,y].flags and d > 0) and adjust(j, k, d) then
      begin
        x := j;
        y := k;
      end;
    end;
  end;
end;


procedure getsize;
var
  j, k : real;
begin
  blockwidth := minblockwidth;
  maxrun := 50;
  j := screenwidth / blockwidth;
  k := screenheight / blockwidth;
  if j = int(j) then
    j := j - 1;
  if k = int(k) then
    k := k - 1;
  width  := trunc(j);
  height := trunc(k);
  if (width > maxx) or (height > maxy) then
  begin
    width  := maxx;
    height := maxy;
  end;
  halfblock := blockwidth div 2;
end;

procedure perezap;
var
  cx, cy: byte;
begin
  clrscr;
  for cx := 1 to maxx * 2 do
  begin
    for cy := 1 to maxy * 2 do
    begin
      cur_lev.map[cx, cy].lev := '#';
      cur_lev.map[cx, cy].color := white;
      cur_lev.map[cx, cy].vid := #0;
      cur_lev.map[cx, cy].now := #0;
      if (cx mod 2 = 0) and (cy mod 2 = 0) then
      begin
        cur_lev.map[cx, cy].lev := FLOOR_CHAR;
        if (cell^[cx div 2, cy div 2].flags and updir > 0) then
          cur_lev.map[cx, cy - 1].lev := FLOOR_CHAR;
        if (cell^[cx div 2, cy div 2].flags and leftdir > 0) then
          cur_lev.map[cx - 1, cy].lev := FLOOR_CHAR;
        if (cell^[cx div 2, cy div 2].flags and rightdir > 0) then
          cur_lev.map[cx + 1, cy].lev := FLOOR_CHAR;
        if (cell^[cx div 2, cy div 2].flags and downdir > 0) then
          cur_lev.map[cx, cy + 1].lev := FLOOR_CHAR;
      end;
    end;
  end;
end;



procedure generate;
begin
    getsize;
    new(cell);
    drawmaze;
    perezap;
end;
begin
end.

