[Back to MISC SWAG index] [Back to Main SWAG index] [Original]

    {
    randyd@csd4.csd.uwm.edu (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.

[Back to MISC SWAG index] [Back to Main SWAG index] [Original]