{ Kevin Smathers:1986 }
program maze;
{$C-}
{Generic version: Turbo Pascal}
{This uses routines built into Turbo Pascal for cursor positioning and other
screen functions. If you can disable your cursor, you may want to do so. Also,
the routines specific to the Superbrain memory mapped video, are included.
    To use memory mapped video, examine the routine OUT and change ISSET to
return type BYTE (for memory) rather than CHAR.

}
const
     ver:string[30]='OxWold presents Mazes (1.0G)';
     hsize=15;
     vsize=10;
     cpoints=3;
     points=4;      {1+cpoints}
type
    compass=0..cpoints;
    mazetype=array[1..hsize,1..vsize] of byte;
    linetype=0..18;

var
   pw:string[20];
   hint:integer;
   ptr:integer;
   x,y:integer;
   gx,gy:integer;
   c:char;
   i:integer;
   hmaze,maze:mazetype;
    linesr,liness:set of linetype;
   lstout:text;
   cur:integer;
   hdata:array[0..50] of string[6];
   l:array [0..32] of string[50];

procedure help;
begin
     gotoxy(1,vsize+3);
     writeln('Rules of the Maze:');
     lowvideo;
     for i:=1 to 8 do begin
         if hint=i then highvideo;
         case i of
              1:writeln('1. You don''t get out until you find the exit');
              2:writeln('2. You move forward by typing "F"');
              3:writeln('3. You turn right by typing "R"');
              4:writeln('4. You turn left by typing "L"');
              5:writeln('5. You turn about by typeing "B"');
              6:writeln('6. You have one piece of chalk, and a great deal of floor space');
              7:writeln('7. You mark on the floor by typing "M"');
              8:writeln('8. When the maze is finished being created, you may continue by typing anything');
         end; {case}
         if hint=i then lowvideo;
     end;
     highvideo;
     Hint:=(hint+1) mod 9;
end;
procedure mazeinit(var maze:mazetype);
var
   i,j,k:integer;

begin
        x:=random(hsize)+1; y:=random(vsize)+1;
        gx:=random(hsize)+1; gy:=random(vsize)+1;
     for i:=1 to hsize do
         for j:=1 to vsize do
         begin
              maze[i,j]:=$FF;
              hmaze[i,j]:=0;
         end;
     for i:=0 to 50 do hdata[i]:='      ';
end;
procedure move(ox,oy:integer; dir:compass; var x,y:integer);
begin
     x:=ox; y:=oy;
     case dir of
          0:y:=y-1;
          1:x:=x+1;
          2:y:=y+1;
          3:x:=x-1;
     end; {case}
end; {move}
function bit(t:byte; tbit:byte):boolean;
begin
     bit:=(t and (1 shl tbit))>0;
end;
procedure map(var maze:mazetype; var fil:text);
var i,j:integer;
begin
        clrscr;
        writeln(FIL,ver);
      for j:=1 to hsize do write(fil,'__'); writeln(fil);
      for i:=1 to vsize do
      begin
           for j:=1 to hsize do
           begin
                if bit(maze[j,i],3) then write(fil,'I') else write(fil,'_');
                if bit(maze[j,i],2) then write(fil,'_') else write(fil,' ');
           end;
           writeln(fil,'I');
      end;
end; {map}

function empty(x,y:integer; maze:mazetype):boolean;
var       i,sum:integer;
begin
     sum:=0;
     if (x in [1..hsize]) and (y in [1..vsize]) then begin
        empty:=(maze[x,y]=$ff);
     end else empty:=false;
end;


procedure makedoor(var x,y:integer; dir:compass; var maze:mazetype);
begin
     maze[x,y]:=maze[x,y] and ($ff xor (1 shl dir));
     if dir=2 then begin gotoxy(x*2,y+2); write(' '); end;
     if dir=1 then begin gotoxy(x*2+1,y+2); write('_'); end;
     move(x,y,dir,x,y);
     dir:=(dir+2) mod points;
     maze[x,y]:=maze[x,y] and ($ff xor (1 shl dir));
     if dir=2 then begin; gotoxy(x*2,y+2); write(' '); end;
     if dir=1 then begin; gotoxy(x*2+1,y+2); write('_'); end;

end; {makedoor}


procedure mazefill(var maze:mazetype);
var
   M,x,y,ox,oy:integer;
   done:boolean;
   d:compass;
   filled:integer;
begin
     filled:=1;
     mazeinit(maze);     map(maze,output);
        writeln;
     x:=random(hsize)+1;
     y:=random(vsize)+1;
     help;
     repeat {fill}
            ox:=x; oy:=y; {save x,y}
            repeat {advance}
                   d:=random(cpoints);
                   done:=false;
                   for m:=0 to cpoints do
                   begin
                        move(ox,oy,(d+m) mod points,x,y);
                        if empty(x,y,maze) and not(done) then
                        begin
                             done:=true;
                             filled:=filled+1;
                             makedoor(ox,oy,(d+m) mod points,maze);
                        end
                   end;
            until not done;
            d:=0; x:=ox; y:=oy;
            repeat {retreat}
                   done:=false;
                   for m:=3 to 7 do {find an opening}
                       if not bit(maze[x,y],(D+M) mod points) and not done then
                       begin
                            done:=true;
                            d:=(d+m) mod points;
                            move(x,y,d,x,y);
                            write(CHR(27),'=',CHR(33+y),CHR(31+x*2));
                       end;
                   if not done then write('error in retreat');
                   done:=false;
                   for m:=0 to 3 do {is there a free space near?}
                   begin
                        move(x,y,m,ox,oy);
                        if empty(ox,oy,maze) then done:=true;
                   end;
            until done or (filled=hsize*vsize);
     until filled=hsize*vsize;
        for ox:=0 to (hsize+vsize) do begin
                d:=random(points);
                x:=random(hsize-2)+2;
                y:=random(vsize-2)+2;
                move(x,y,d,x,y);
                if (x in [1..hsize]) and (y in [1..vsize]) then
                        makedoor(x,y,(d+2) mod points,maze);
        end;
      repeat
            help;
            delay(500);
      until keypressed;
end; {mazefill}
Function ISSET(VAR SSET:BOOLEAN; C:CHAR):char;
BEGIN
     IF SSET THEN ISSET:=(C) ELSE ISSET:=' ';
END;

procedure out(num:integer; sset:boolean);
var i,j:integer;
begin
     for i:=1 to length(l[num]) do BEGIN
         case l[num][i] of
              #0..#31: begin
                   cur:=80*ord(l[num][i])+ord(l[num][i-1]);
              end;
              'J': cur:=cur+80;
              'R': cur:=cur+78;
              '=': begin
                   gotoxy(cur mod 80,cur div 80);
                   write(ISSET(sset,'+'));
              end;
              #100..#199:begin
                   gotoxy(cur mod 80, cur div 80);
                   for j:=1 to ord(l[num][i])-100 do begin
                       write(isset(sset,'-'));
                       cur:=cur+1;
                       end;
                   end;
              #200..#299:
                   for j:=1 to ord(l[num][i])-200 do begin
                       gotoxy(cur mod 80, cur div 80);
                       write(isset(sset,'|'));
                       cur:=cur+80;
                   end;
              else begin
                  gotoxy(cur mod 80,cur div 80);
                  write(isset(sset,l[num][i]));
                  cur:=cur+1;
              end;
         end;
         END;
end;
{{{{{{{{{{{{{ This routine is Intertec Superbrain specific
procedure out(num:integer; sset:boolean);
{ Memory mapped video starts at $F800 and proceeds at 80 characters
per line.  The screen must first be cleared and then written to each
line (to clear video blanking) The routing actually only used ~ 27
characters on each line.}
{{{{{{{{{{{{{
var i,j:integer;
begin
     for i:=1 to length(l[num]) do BEGIN
         case l[num][i] of
              #0..#31: begin
                   cur:=$f800+80*ord(l[num][i])+ord(l[num][i-1]);
                   if (cur < $f800) or (cur > $f800+1920) then
              end;
              'J': cur:=cur+80;
              'R': cur:=cur+78;
              '=': mem[cur]:=ISSET(sset,'+');

              #100..#199:
                   for j:=1 to ord(l[num][i])-100 do begin
                       mem[cur]:=isset(sset,'-');
                       cur:=cur+1;
                   end;
              #200..#299:
                   for j:=1 to ord(l[num][i])-200 do begin
                       mem[cur]:=isset(sset,'|');
                       cur:=cur+80;
                   end;
              else begin
                  mem[cur]:=isset(sset,l[num][i]);
                  cur:=cur+1;
              end;
              END;
         end;
end;
End of Intertec Superbrain routine
{{{{{{{{{{{{{{{}

procedure outr(num:linetype);
begin
        if num in liness then begin
                liness:=liness-[num];
                linesr:=linesr+[num];
                out(num,false);
        end;
end;
procedure outs(num:linetype);
begin
        if num in linesr then begin
                linesr:=linesr-[num];
                liness:=liness+[num];
                out(num,true);
        end;
end;
procedure outset(k:boolean; l1,l2:linetype);
begin
        if k then begin
                outs(l1); outr(l2);
        end else begin
                outs(l2); outr(l1);
        end;
end;

procedure mazeroom(var maze:mazetype; x,y:integer; d:compass);
var i,tx,ty:integer;

begin
        outset(bit(maze[x,y],(d+3) mod points),1,0);
        outset(bit(maze[x,y],(d+1) mod points),3,2);
        outs(15);
        if bit(maze[x,y],d) then begin
                outs(12);
                for i:=4 to 11 do outr(i);
                for i:=13 to 14 do outr(i);
                for i:=16 to 18 do outr(i);
        end else begin
                outr(12);
                move(x,y,d,tx,ty);
                if (tx=gx) and (ty=gy) then begin
                   gotoxy(14,21);
                   write('EXIT');
                end else begin
                   gotoxy(14,21);
                   write(hdata[hmaze[tx,ty]]);
                end;
                outs(16);
                outset(bit(maze[tx,ty],(d+3) mod points),5,4);
                outset(bit(maze[tx,ty],(d+1) mod points),7,6);
                if bit(maze[tx,ty],d) then begin
                        outs(13);
                        for i:=8 to 11 do outr(i);
                        outr(14); outr(17); outr(18);
                end else begin
                        outr(13);
                        move(tx,ty,d,tx,ty);
                        outset(bit(maze[tx,ty],(d+3) mod points),9,8);
                        outset(bit(maze[tx,ty],(d+1) mod points),11,10);
                        outset(bit(maze[tx,ty],d),14,18);
                        outs(17);
                end;
        end;
end;
procedure mazewander(var maze:mazetype);
var
        d:compass;
        c:char;
begin
        d:=random(points);
        liness:=[]; linesr:=[0..18];
        repeat
                mazeroom(maze,x,y,d);
                gotoxy(35,1);
                clreol;
                write(':');
                read(kbd,c);
                write(c);
                gotoxy(35,2);
                write('     ');
        case c of
                'L','l':d:=(d+3) mod points;
                'F','f':if bit(maze[x,y],d) then begin
                           gotoxy(35,2);
                           write('OUCH!')
                        end  else move(x,y,d,x,y);
                'R','r':d:=(d+1) mod points;
                'B','b':d:=(d+2) mod points;
                'M','m':if ptr=50 then
                           write('You are all out of chalk')
                        else begin
                             ptr:=ptr+1;
                             write('Mark what?        '^h^h^h^h^h^h);
                             readln(hdata[ptr]);
                             hdata[ptr]:=hdata[ptr]+'      ';
                             hmaze[x,y]:=ptr;
                        end;
        end; {case}
        until ((x=gx) and (y=gy)) or (c=^^);
end; {maze wander}
procedure init;
begin
{ 0..33 goto (x,y) pair with next byte
  J     Line feed
  R     Line feed less two spaces
  others 65..99 print as is or as space depending on set or reset
  100..199      N-100 horizontal
  200..255      N-200 vertical
}
     l[00]:=#1#2'--'#1#22'--';           {Left immediate open}
     l[01]:=#2#1'\'#2#23'/';             {Left immediate closed}
     l[02]:=#27#2'--'#27#22'--';         {Right immediate open}
     l[03]:=#27#1'/'#27#23'\';           {Right immediate closed}
     l[04]:=#4#6'---'#4#18'---';         {Next left open}
     l[05]:=#4#3'\J\J\'#6#19'/R/R/';     {Next left closed}
     l[06]:=#23#6'---'#23#18'---';       {Next right open}
     l[07]:=#25#3'/R/R/'#23#19'\J\J\';   {Next right closed}
     L[08]:=#8#8'-'#8#16'-';             {Last left open}
     L[09]:=#8#7'\'#8#17'/';             {Last left closed}
     L[10]:=#21#8'-'#21#16'-';           {Last right open}
     L[11]:=#21#7'/'#21#17'\';           {Last right closed}
     L[12]:=#4#2#122#4#22#122;           {Closed immediatly ahead}
     L[13]:=#8#6#114#8#18#114;           {Closed next ahead}
     L[14]:=#10#8#110#10#16#110;         {Closed last ahead}
     l[15]:=#3#2'=J'#219'=J'#26#2'=J'#219'=';  {end of immediate room}
     l[16]:=#7#6'=J'#211'=J'#22#6'=J'#211'=';  {end of next room}
     l[17]:=#9#8'=J'#207'=J'#20#8'=J'#207'=';  {end of last room}
     l[18]:=#10#9'\'#10#15'/'#19#9'/'#19#15'\';{open all ahead}
     ptr:=0;
     hint:=0;
end;
begin {main}
        init;
      mazefill(maze);
      read(kbd,c);
      if c='P' then map(maze,lst);
        clrscr;
        for i:=1 to 23 do writeln(' ');
        write(' '^h);
        mazewander(maze);
        clrscr;
        writeln('Hurrah! You made it out!');
end. {main}