POINT Software Programming/PPROG1.ISO/pascal/swag/misc.swg/0064_Maze Generator.pas

Pascal/Delphi Source File | 1993-11-02 | 12.2 KB | 473 lines

{
[e-mail] (Randall Elton Ding)

This is really for Allen who earlier in the month asked about generating
a maze in pascal.  It may not really be the fastest, but I know of
no other way which is faster.  Check it out, it lets you try to move
thru the maze, when you give up it shows you the way.  It has variable
difficulty and size too.

This was origionally written in Apple][ 6502 machine language, I ported
it over to pascal a few years later.
}

(* Big Mind Over Maze
   maze generator and solver
   created by Randy Ding
   July 16,1983   <April 21,1992>  *)

{$R-}   { range checking }

program makemaze;

uses
  crt, graph;

const
  screenwidth   = 640;
  screenheight  = 350;
  minblockwidth = 2;
  maxx = 200;   { [3 * maxx * maxy] must be less than 65520 (memory segment) }
  maxy = 109;   { here maxx/maxy about equil to screenwidth/screenheight }
  flistsize = 5000; { flist size (fnum max, about 1/3 of maxx * maxy) }

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

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

  unused   = $00;    { cell types used as flag bits }
  frontier = $10;
  reserved = $20;
  tree     = $30;


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

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

  {
    one byte per cell, flag bits...

    0: right, 1 = barrier removed
    1: top    "
    2: left   "
    3: bottom "
    5,4: 0,0 = unused cell type
         0,1 = frontier "
         1,1 = tree     "
         1,0 = reserved "
    6: (not used)
    7: solve path, 1 = this cell part of solve path
  }


var
  flist     : farr;         { list of frontier cells in random order }
  cell      : ^cellarr;      { pointers and flags, on heap }
  fnum,
  width,
  height,
  blockwidth,
  halfblock,
  maxrun    : word;
  runset    : byte;
  ch        : char;

procedure initbgi;
var
  grdriver,
  grmode,
  errcode : integer;
begin
  grdriver := DETECT;
  grmode   := EGAhi;
  initgraph(grdriver, grmode, 'e:\bp\bgi');
  errcode:= graphresult;
  if errcode <> grok then
  begin
    writeln('Graphics error: ', grapherrormsg(errcode));
    halt(1);
  end;
end;


function adjust(var x, y : word; d : byte) : boolean;
begin                              { take x,y to next cell in direction d }
  case d of                        { returns false if new x,y is off grid }
    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);      { remove a frontier cell from flist }
var
  i : word; { done by moving last entry in flist into it's place }
begin
  i := cell^[x,y].point;          { old pointer }
  with flist[fnum] do
    cell^[column,row].point := i;   { move pointer }
  flist[i] := flist[fnum];        { move data }
  dec(fnum);                    { one less to worry about }
end;


procedure add(x, y : word; d : byte);  { add a frontier cell to flist }
var
  i : byte;
begin
  i := cell^[x,y].flags;
  case i and $30 of   { check cell type }
    unused :
    begin
      cell^[x,y].flags := i or frontier;  { change to frontier cell }
      inc(fnum);                        { have one more to worry about }
      if fnum > flistsize then
      begin     { flist overflow error! }
        dispose(cell);  { clean up memory }
        closegraph;
        writeln('flist overflow! - To correct, increase "flistsize"');
        write('hit return to halt program ');
        readln;
        halt(1);        { exit program }
      end;
      with flist[fnum] do
      begin    { copy data into last entry of flist }
        column := x;
        row    := y;
      end;
      cell^[x,y].point := fnum; { make the pointer point to the new cell }
      runset := runset or d;   { indicate that a cell in direction d was }
    end;                      {    added to the flist }

    frontier : runset := runset or d;     { allready in flist }
  end;
end;


procedure addfront(x, y : word);    { change all unused cells around this }
var                              {    base cell to frontier cells }
  j, k : word;
  d    : byte;
begin
  remove(x, y);       { first remove base cell from flist, it is now }
  runset := 0;         {    part of the tree }
  cell^[x,y].flags := cell^[x,y].flags or tree;   { change to tree cell }
  d := $01;            { look in all four directions- $01,$02,$04,$08 }
  while d <= $08 do
  begin
    j := x;
    k := y;
    if adjust(j, k, d) then
      add(j, k, d);  { add only if still in bounds }
    d := d shl 1;    { try next direction }
  end;
end;


procedure remline(x, y : word; d : byte);  { erase line connecting two blocks }
begin
  setcolor(background);
  x := (x - 1) * blockwidth;
  y := (y - 1) * blockwidth;
  case d of
    rightdir : line (x + blockwidth, y + 1, x + blockwidth, y + blockwidth - 1);
    updir    : line (x + 1, y, x + blockwidth - 1, y);
    leftdir  : line (x, y + 1, x, y + blockwidth - 1);
    downdir  : line (x + 1, y + blockwidth, x + blockwidth - 1, y + blockwidth);
  end;
end;


{ erase line and update flags to indicate the barrier has been removed }
procedure rembar(x, y : word; d : byte);
var
  d2 : byte;
begin
  remline(x, y, d);       { erase line }
  cell^[x,y].flags := cell^[x,y].flags or d; { show barrier removed dir. d }
  d2 := d shl 2;  { shift left twice to reverse direction }
  if d2 > $08 then
    d2 := d2 shr 4;  { wrap around }
  if adjust(x, y, d) then  { do again from adjacent cell back to base cell }
    cell^[x,y].flags := cell^[x,y].flags or d2;    { skip if out of bounds }
end;


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


procedure connect(x, y : word);    { connect this new branch to the tree }
var                             {    in a random direction }
  j, k  : word;
  d     : byte;
  found : boolean;
begin
  found := false;
  while not found do
  begin { loop until we find a tree cell to connect to }
    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);   { remove barrier connecting the cells }
end;


procedure branch(x, y : word);  { make a new branch of the tree }
var
  runnum : word;
  d      : byte;
  i      : boolean;
begin
  runnum := maxrun;      { max number of tree cells to add to a branch }
  connect(x, y);        { first connect frontier cell to the tree }
  addfront(x, y);       { convert neighboring unused cells to frontier }
  dec(runnum);         { number of tree cells left to add to this branch }
  while (runnum > 0) and (fnum > 0) and (runset > 0) do
  begin
    repeat
      d := randomdir;
    until d and runset > 0;  { pick random direction to known frontier }
    rembar(x, y, d);          {    and make it part of the tree }
    i := adjust(x, y, d);
    addfront(x, y);      { then pick up the neighboring frontier cells }
    dec(runnum);
  end;
end;


procedure drawmaze;
var
  x, y, i : word;
begin
  setcolor(gridcolor);    { draw the grid }
  y := height * blockwidth;
  for i := 0 to width do
  begin
    x := i * blockwidth;
    line(x, 0, x, y);
  end;
  x := width * blockwidth;
  for i := 0 to height do
  begin
    y := i * blockwidth;
    line (0, y, x, y);
  end;
  fillchar(cell^, sizeof(cell^), chr(0));    { zero flags }
  fnum   := 0;   { number of frontier cells in flist }
  runset := 0; { directions to known frontier cells from a base cell }
  randomize;
  x := random(width) + 1;   { pick random start cell }
  y := random(height) + 1;
  add(x, y, rightdir);       { direction ignored }
  addfront(x, y);      { start with 1 tree cell and some frontier cells }
  while (fnum > 0) do
  with flist[random(fnum) + 1] do
    branch(column, row);
end;

procedure dot(x, y, colr : word);
begin
  putpixel(blockwidth * x - halfblock, blockwidth * y - halfblock, colr);
end;

procedure solve(x, y, endx, endy : word);
var
  j, k : word;
  d    : byte;
  i    : boolean;
begin
  d := rightdir;  { starting from left side of maze going right }
  while (x <> endx) or (y <> endy) do
  begin
    if d = $01 then
      d := $08
    else
      d := d shr 1; { look right, hug right wall }
    while cell^[x,y].flags and d = 0 do
    begin { look for an opening }
      d := d shl 1;                            { if no opening, turn left }
      if d > $08 then
        d := d shr 4;
    end;
    j := x;
    k := y;
    i := adjust(x, y, d);         { go in that direction }
    with cell^[j,k] do
    begin    { turn on dot, off if we were here before }
      flags := ((((cell^[x,y].flags xor $80) xor flags) and $80) xor flags);
      if flags and $80 <> 0 then
        dot(j, k, solvecolor)
      else
        dot(j, k, background);
    end;
  end;
  dot(endx, endy, solvecolor);    { dot last cell on }
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
    dot(x, y, solvecolor);    { dot man on, show where we are in maze }
    ch := upcase(readkey);
    dot(x, y, background);    { dot man off after keypress }
    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;    { move if no wall and still in bounds }
      if (cell^[x,y].flags and d > 0) and adjust(j, k, d) then
      begin
        x := j;
        y := k;
      end;
    end;
  end;
end;

procedure solvemaze;
var
  x, y,
  endx,
  endy : word;
  ch   : char;
begin
  x := 1;                         { pick random start on left side wall }
  y := random(height) + 1;
  endx := width;                  { pick random end on right side wall }
  endy := random(height) + 1;
  remline(x, y, leftdir);         { show start and end by erasing line }
  remline(endx, endy, rightdir);
  mansolve(x, y, endx, endy);      { try it manually }
  solve(x, y, endx, endy);         { show how when he gives up }
  while keypressed do
    ch := readkey;
  ch := readkey;
end;


procedure getsize;
var
  j, k : real;
begin
  clrscr;
  writeln('       Mind');
  writeln('       Over');
  writeln('       Maze');
  writeln;
  writeln('   by Randy Ding');
  writeln;
  writeln('Use I,J,K,M or arrow keys to walk thru maze,');
  writeln('then hit X when you give up!');
  repeat
    writeln;
    write('Maze size: ', minblockwidth, ' (hard) .. 95 (easy) ');
    readln(blockwidth);
  until (blockwidth >= minblockwidth) and (blockwidth < 96);
  writeln;
  write('Maximum branch length: 1 easy .. 50 harder, (0 unlimited) ');
  readln(maxrun);
  if maxrun <= 0 then
    maxrun := 65535;  { infinite }
  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;

begin
  repeat
    getsize;
    initbgi;
    new(cell);    { allocate this large array on heap }
    drawmaze;
    solvemaze;
    dispose(cell);
    closegraph;
    while keypressed do
      ch := readkey;
    write ('another one? ');
    ch := upcase (readkey);
  until (ch = 'N') or (ch = #27);
end.